diff options
Diffstat (limited to 'src')
107 files changed, 6258 insertions, 23431 deletions
diff --git a/src/Makefile.am b/src/Makefile.am index c86582a2..f1bc29d1 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -12,4 +12,4 @@ datarootdir = @prefix@/share -SUBDIRS = couch_inets couchdb +SUBDIRS = couchdb mochiweb diff --git a/src/couch_inets/Makefile.am b/src/couch_inets/Makefile.am deleted file mode 100644 index fa5954c1..00000000 --- a/src/couch_inets/Makefile.am +++ /dev/null @@ -1,177 +0,0 @@ -## Licensed under the Apache License, Version 2.0 (the "License"); you may not -## use this file except in compliance with the License. You may obtain a copy -## of the License at -## -## http://www.apache.org/licenses/LICENSE-2.0 -## -## Unless required by applicable law or agreed to in writing, software -## distributed under the License is distributed on an "AS IS" BASIS, WITHOUT -## WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the -## License for the specific language governing permissions and limitations -## under the License. - -datarootdir = @prefix@/share - -couchinetsebindir = $(erlanglibdir)/couch_inets-4.7.5/ebin -couchinetsincludedir = $(erlanglibdir)/couch_inets-4.7.5/include - -couchinets_file_collection = \ - ftp.erl \ - ftp_progress.erl \ - ftp_response.erl \ - ftp_sup.erl \ - http_base_64.erl \ - httpc_handler.erl \ - http_chunk.erl \ - httpc_manager.erl \ - http_cookie.erl \ - httpc_request.erl \ - httpc_response.erl \ - httpc_sup.erl \ - httpd_acceptor.erl \ - httpd_acceptor_sup.erl \ - httpd_cgi.erl \ - httpd_conf.erl \ - httpd.erl \ - httpd_esi.erl \ - httpd_example.erl \ - httpd_instance_sup.erl \ - httpd_manager.erl \ - httpd_misc_sup.erl \ - httpd_request.erl \ - httpd_request_handler.erl \ - httpd_response.erl \ - httpd_script_env.erl \ - httpd_socket.erl \ - httpd_sup.erl \ - httpd_util.erl \ - http.erl \ - http_request.erl \ - http_response.erl \ - http_transport.erl \ - http_uri.erl \ - http_util.erl \ - inets_app.erl \ - inets.erl \ - inets_sup.erl \ - mod_actions.erl \ - mod_alias.erl \ - mod_auth_dets.erl \ - mod_auth.erl \ - mod_auth_mnesia.erl \ - mod_auth_plain.erl \ - mod_auth_server.erl \ - mod_browser.erl \ - mod_cgi.erl \ - mod_dir.erl \ - mod_disk_log.erl \ - mod_esi.erl \ - mod_get.erl \ - mod_head.erl \ - mod_htaccess.erl \ - mod_include.erl \ - mod_log.erl \ - mod_range.erl \ - mod_responsecontrol.erl \ - mod_security.erl \ - mod_security_server.erl \ - mod_trace.erl \ - tftp_binary.erl \ - tftp_engine.erl \ - tftp.erl \ - tftp_file.erl \ - tftp_lib.erl \ - tftp_sup.erl - -couchinetsebin_static_file = couch_inets.app - -couchinetsebin_generated_file_list = \ - ftp.beam \ - ftp_progress.beam \ - ftp_response.beam \ - ftp_sup.beam \ - http_base_64.beam \ - http.beam \ - httpc_handler.beam \ - http_chunk.beam \ - httpc_manager.beam \ - http_cookie.beam \ - httpc_request.beam \ - httpc_response.beam \ - httpc_sup.beam \ - httpd_acceptor.beam \ - httpd_acceptor_sup.beam \ - httpd.beam \ - httpd_cgi.beam \ - httpd_conf.beam \ - httpd_esi.beam \ - httpd_example.beam \ - httpd_instance_sup.beam \ - httpd_manager.beam \ - httpd_misc_sup.beam \ - httpd_request.beam \ - httpd_request_handler.beam \ - httpd_response.beam \ - httpd_script_env.beam \ - httpd_socket.beam \ - httpd_sup.beam \ - httpd_util.beam \ - http_request.beam \ - http_response.beam \ - http_transport.beam \ - http_uri.beam \ - http_util.beam \ - inets_app.beam \ - inets.beam \ - inets_sup.beam \ - mod_actions.beam \ - mod_alias.beam \ - mod_auth.beam \ - mod_auth_dets.beam \ - mod_auth_mnesia.beam \ - mod_auth_plain.beam \ - mod_auth_server.beam \ - mod_browser.beam \ - mod_cgi.beam \ - mod_dir.beam \ - mod_disk_log.beam \ - mod_esi.beam \ - mod_get.beam \ - mod_head.beam \ - mod_htaccess.beam \ - mod_include.beam \ - mod_log.beam \ - mod_range.beam \ - mod_responsecontrol.beam \ - mod_security.beam \ - mod_security_server.beam \ - mod_trace.beam \ - tftp.beam \ - tftp_binary.beam \ - tftp_engine.beam \ - tftp_file.beam \ - tftp_lib.beam \ - tftp_sup.beam - -couchinetsinclude_DATA = \ - ftp_internal.hrl \ - httpc_internal.hrl \ - httpd.hrl \ - http_internal.hrl \ - inets_internal.hrl \ - mod_auth.hrl \ - tftp.hrl - -couchinetsebin_DATA = \ - $(couchinetsebin_static_file) \ - $(couchinetsebin_generated_file_list) - -EXTRA_DIST = \ - $(couchinets_file_collection) \ - $(couchinetsinclude_DATA) \ - $(couchinetsebin_static_file) - -CLEANFILES = $(couchinetsebin_generated_file_list) - -%.beam: %.erl - erlc $< diff --git a/src/couch_inets/couch_inets.app b/src/couch_inets/couch_inets.app deleted file mode 100644 index cdbd0f9b..00000000 --- a/src/couch_inets/couch_inets.app +++ /dev/null @@ -1,84 +0,0 @@ -{application,couch_inets, - [{description,"Couch INETS"}, - {vsn,"4.7.5"}, - {modules,[ - inets, - inets_sup, - inets_app, - - %% FTP - ftp, - ftp_progress, - ftp_response, - ftp_sup, - - %% HTTP client: - http, - httpc_handler, - httpc_manager, - httpc_request, - httpc_response, - httpc_sup, - http_cookie, - http_uri, - - %% HTTP used by both client and server - http_base_64, - http_chunk, - http_request, - http_response, - http_transport, - http_util, - - %% HTTP server: - httpd, - httpd_acceptor, - httpd_acceptor_sup, - httpd_cgi, - httpd_conf, - httpd_esi, - httpd_example, - httpd_instance_sup, - httpd_manager, - httpd_misc_sup, - httpd_request, - httpd_request_handler, - httpd_response, - httpd_script_env, - httpd_socket, - httpd_sup, - httpd_util, - 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, - - %% TFTP - tftp, - tftp_binary, - tftp_engine, - tftp_file, - tftp_lib, - tftp_sup - ]}, - {registered,[inets_sup, httpc_manager]}, - {applications,[kernel,stdlib]}, - {mod,{inets_app,[]}}]}. diff --git a/src/couch_inets/ftp.erl b/src/couch_inets/ftp.erl deleted file mode 100644 index 92483943..00000000 --- a/src/couch_inets/ftp.erl +++ /dev/null @@ -1,1597 +0,0 @@ -%% ``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$ -%% -%% Description: This module implements an ftp client, RFC 959. -%% It also supports ipv6 RFC 2428. - --module(ftp). - --behaviour(gen_server). - -%% API - Client interface --export([cd/2, close/1, delete/2, formaterror/1, - lcd/2, lpwd/1, ls/1, ls/2, - mkdir/2, nlist/1, nlist/2, - open/1, open/2, open/3, force_active/1, - pwd/1, quote/2, - 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]). - -%% gen_server callbacks --export([init/1, handle_call/3, handle_cast/2, - handle_info/2, terminate/2, code_change/3]). - -%% supervisor callbacks --export([start_link_sup/1]). - --include("ftp_internal.hrl"). - -%% Constante used in internal state definition --define(CONNECTION_TIMEOUT, 60*1000). --define(DEFAULT_MODE, passive). - -%% Internal Constants --define(FTP_PORT, 21). --define(FILE_BUFSIZE, 4096). - -%% Internal state --record(state, { - csock = undefined, % socket() - Control connection socket - dsock = undefined, % socket() - Data connection socket - verbose = false, % boolean() - ldir = undefined, % string() - Current local directory - type = ftp_server_default, % atom() - binary | ascii - chunk = false, % boolean() - Receiving data chunks - mode = ?DEFAULT_MODE, % passive | active - timeout = ?CONNECTION_TIMEOUT, % integer() - %% Data received so far on the data connection - data = <<>>, % binary() - %% Data received so far on the control connection - %% {BinStream, AccLines}. If a binary sequence - %% ends with ?CR then keep it in the binary to - %% be able to detect if the next received byte is ?LF - %% and hence the end of the response is reached! - ctrl_data = {<<>>, [], start}, % {binary(), [bytes()], LineStatus} - %% pid() - Client pid (note not the same as "From") - owner = undefined, - client = undefined, % "From" to be used in gen_server:reply/2 - %% Function that activated a connection and maybe some - %% data needed further on. - caller = undefined, % term() - ip_v6_disabled, % boolean() - progress = ignore % ignore | pid() - }). - -%%%========================================================================= -%%% API - CLIENT FUNCTIONS -%%%========================================================================= -%%-------------------------------------------------------------------------- -%% open(Host, <Port>, <Flags>) -> {ok, Pid} | {error, ehost} -%% Host = string(), -%% Port = integer(), -%% Flags = [Flag], -%% Flag = verbose | debug | trace -%% -%% Description: Start an ftp client and connect to a host. -%%-------------------------------------------------------------------------- -%% The only option was the host in textual form -open({option_list, Options})-> - ensure_started(), - Flags = key_search(flags, Options, []), - {ok, Pid} = ftp_sup:start_child([[[{client, self()}, Flags], []]]), - call(Pid, {open, ip_comm, Options}, pid); - -%% 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) -> - ensure_started(), - {ok, Pid} = ftp_sup:start_child([[[{client, self()}, Flags], []]]), - Opts = [{host, Host}, {port, Port}| Flags], - call(Pid, {open, ip_comm, Opts}, pid). - -%%-------------------------------------------------------------------------- -%% user(Pid, User, Pass, <Acc>) -> ok | {error, euser} | {error, econn} -%% | {error, eacct} -%% Pid = pid(), -%% User = Pass = Acc = string() -%% -%% Description: Login with or without a supplied account name. -%%-------------------------------------------------------------------------- -user(Pid, User, Pass) -> - call(Pid, {user, User, Pass}, atom). - -user(Pid, User, Pass, Acc) -> - call(Pid, {user, User, Pass, Acc}, atom). - -%%-------------------------------------------------------------------------- -%% account(Pid, Acc) -> ok | {error, eacct} -%% Pid = pid() -%% Acc= string() -%% -%% Description: Set a user Account. -%%-------------------------------------------------------------------------- -account(Pid, Acc) -> - call(Pid, {account, Acc}, atom). - -%%-------------------------------------------------------------------------- -%% pwd(Pid) -> {ok, Dir} | {error, elogin} | {error, econn} -%% Pid = pid() -%% Dir = string() -%% -%% Description: Get the current working directory at remote server. -%%-------------------------------------------------------------------------- -pwd(Pid) -> - call(Pid, pwd, ctrl). - -%%-------------------------------------------------------------------------- -%% lpwd(Pid) -> {ok, Dir} | {error, elogin} -%% Pid = pid() -%% Dir = string() -%% -%% Description: Get the current working directory at local server. -%%-------------------------------------------------------------------------- -lpwd(Pid) -> - call(Pid, lpwd, string). - -%%-------------------------------------------------------------------------- -%% cd(Pid, Dir) -> ok | {error, epath} | {error, elogin} | {error, econn} -%% Pid = pid() -%% Dir = string() -%% -%% Description: Change current working directory at remote server. -%%-------------------------------------------------------------------------- -cd(Pid, Dir) -> - call(Pid, {cd, Dir}, atom). - -%%-------------------------------------------------------------------------- -%% lcd(Pid, Dir) -> ok | {error, epath} -%% Pid = pid() -%% Dir = string() -%% -%% Description: Change current working directory for the local client. -%%-------------------------------------------------------------------------- -lcd(Pid, Dir) -> - call(Pid, {lcd, Dir}, string). - -%%-------------------------------------------------------------------------- -%% ls(Pid, <Dir>) -> {ok, Listing} | {error, epath} | {error, elogin} | -%% {error, econn} -%% Pid = pid() -%% Dir = string() -%% Listing = string() -%% -%% Description: List the contents of current directory (ls/1) or -%% directory Dir (ls/2) at remote server. -%%-------------------------------------------------------------------------- -ls(Pid) -> - ls(Pid, ""). -ls(Pid, Dir) -> - call(Pid, {dir, long, Dir}, string). - -%%-------------------------------------------------------------------------- -%% nlist(Pid, <Dir>) -> {ok, Listing} | {error, epath} | {error, elogin} | -%% {error, econn} -%% Pid = pid() -%% Dir = string() -%% -%% Description: 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. -%%-------------------------------------------------------------------------- -nlist(Pid) -> - nlist(Pid, ""). -nlist(Pid, Dir) -> - call(Pid, {dir, short, Dir}, string). - -%%-------------------------------------------------------------------------- -%% rename(Pid, CurrFile, NewFile) -> ok | {error, epath} | {error, elogin} -%% | {error, econn} -%% Pid = pid() -%% CurrFile = NewFile = string() -%% -%% Description: Rename a file at remote server. -%%-------------------------------------------------------------------------- -rename(Pid, CurrFile, NewFile) -> - call(Pid, {rename, CurrFile, NewFile}, string). - -%%-------------------------------------------------------------------------- -%% delete(Pid, File) -> ok | {error, epath} | {error, elogin} | -%% {error, econn} -%% Pid = pid() -%% File = string() -%% -%% Description: Remove file at remote server. -%%-------------------------------------------------------------------------- -delete(Pid, File) -> - call(Pid, {delete, File}, string). - -%%-------------------------------------------------------------------------- -%% mkdir(Pid, Dir) -> ok | {error, epath} | {error, elogin} | {error, econn} -%% Pid = pid(), -%% Dir = string() -%% -%% Description: Make directory at remote server. -%%-------------------------------------------------------------------------- -mkdir(Pid, Dir) -> - call(Pid, {mkdir, Dir}, atom). - -%%-------------------------------------------------------------------------- -%% rmdir(Pid, Dir) -> ok | {error, epath} | {error, elogin} | {error, econn} -%% Pid = pid(), -%% Dir = string() -%% -%% Description: Remove directory at remote server. -%%-------------------------------------------------------------------------- -rmdir(Pid, Dir) -> - call(Pid, {rmdir, Dir}, atom). - -%%-------------------------------------------------------------------------- -%% type(Pid, Type) -> ok | {error, etype} | {error, elogin} | {error, econn} -%% Pid = pid() -%% Type = ascii | binary -%% -%% Description: Set transfer type. -%%-------------------------------------------------------------------------- -type(Pid, Type) -> - call(Pid, {type, Type}, atom). - -%%-------------------------------------------------------------------------- -%% recv(Pid, RemoteFileName <LocalFileName>) -> ok | {error, epath} | -%% {error, elogin} | {error, econn} -%% Pid = pid() -%% RemoteFileName = LocalFileName = string() -%% -%% Description: Transfer file from remote server. -%%-------------------------------------------------------------------------- -recv(Pid, RemotFileName) -> - recv(Pid, RemotFileName, RemotFileName). - -recv(Pid, RemotFileName, LocalFileName) -> - call(Pid, {recv, RemotFileName, LocalFileName}, atom). - -%%-------------------------------------------------------------------------- -%% recv_bin(Pid, RemoteFile) -> {ok, Bin} | {error, epath} | {error, elogin} -%% | {error, econn} -%% Pid = pid() -%% RemoteFile = string() -%% Bin = binary() -%% -%% Description: Transfer file from remote server into binary. -%%-------------------------------------------------------------------------- -recv_bin(Pid, RemoteFile) -> - call(Pid, {recv_bin, RemoteFile}, bin). - -%%-------------------------------------------------------------------------- -%% recv_chunk_start(Pid, RemoteFile) -> ok | {error, elogin} | {error, epath} -%% | {error, econn} -%% Pid = pid() -%% RemoteFile = string() -%% -%% Description: Start receive of chunks of remote file. -%%-------------------------------------------------------------------------- -recv_chunk_start(Pid, RemoteFile) -> - call(Pid, {recv_chunk_start, RemoteFile}, atom). - -%%-------------------------------------------------------------------------- -%% recv_chunk(Pid, RemoteFile) -> ok | {ok, Bin} | {error, Reason} -%% Pid = pid() -%% RemoteFile = string() -%% -%% Description: Transfer file from remote server into binary in chunks -%%-------------------------------------------------------------------------- -recv_chunk(Pid) -> - call(Pid, recv_chunk, atom). - -%%-------------------------------------------------------------------------- -%% send(Pid, LocalFileName <RemotFileName>) -> ok | {error, epath} -%% | {error, elogin} -%% | {error, econn} -%% Pid = pid() -%% LocalFileName = RemotFileName = string() -%% -%% Description: Transfer file to remote server. -%%-------------------------------------------------------------------------- -send(Pid, LocalFileName) -> - send(Pid, LocalFileName, LocalFileName). - -send(Pid, LocalFileName, RemotFileName) -> - call(Pid, {send, LocalFileName, RemotFileName}, atom). - -%%-------------------------------------------------------------------------- -%% send_bin(Pid, Bin, RemoteFile) -> ok | {error, epath} | {error, elogin} -%% | {error, enotbinary} | {error, econn} -%% Pid = pid() -%% Bin = binary() -%% RemoteFile = string() -%% -%% Description: Transfer a binary to a remote file. -%%-------------------------------------------------------------------------- -send_bin(Pid, Bin, RemoteFile) when binary(Bin) -> - call(Pid, {send_bin, Bin, RemoteFile}, atom); -send_bin(_Pid, _Bin, _RemoteFile) -> - {error, enotbinary}. - -%%-------------------------------------------------------------------------- -%% send_chunk_start(Pid, RemoteFile) -> ok | {error, elogin} | {error, epath} -%% | {error, econn} -%% Pid = pid() -%% RemoteFile = string() -%% -%% Description: Start transfer of chunks to remote file. -%%-------------------------------------------------------------------------- -send_chunk_start(Pid, RemoteFile) -> - call(Pid, {send_chunk_start, RemoteFile}, atom). - -%%-------------------------------------------------------------------------- -%% append_chunk_start(Pid, RemoteFile) -> ok | {error, elogin} | -%% {error, epath} | {error, econn} -%% Pid = pid() -%% RemoteFile = string() -%% -%% Description: Start append chunks of data to remote file. -%%-------------------------------------------------------------------------- -append_chunk_start(Pid, RemoteFile) -> - call(Pid, {append_chunk_start, RemoteFile}, atom). - -%%-------------------------------------------------------------------------- -%% send_chunk(Pid, Bin) -> ok | {error, elogin} | {error, enotbinary} -%% | {error, echunk} | {error, econn} -%% Pid = pid() -%% Bin = binary(). -%% -%% Purpose: Send chunk to remote file. -%%-------------------------------------------------------------------------- -send_chunk(Pid, Bin) when binary(Bin) -> - call(Pid, {transfer_chunk, Bin}, atom); -send_chunk(_Pid, _Bin) -> - {error, enotbinary}. - -%%-------------------------------------------------------------------------- -%% append_chunk(Pid, Bin) -> ok | {error, elogin} | {error, enotbinary} -%% | {error, echunk} | {error, econn} -%% Pid = pid() -%% Bin = binary() -%% -%% Description: Append chunk to remote file. -%%-------------------------------------------------------------------------- -append_chunk(Pid, Bin) when binary(Bin) -> - call(Pid, {transfer_chunk, Bin}, atom); -append_chunk(_Pid, _Bin) -> - {error, enotbinary}. - -%%-------------------------------------------------------------------------- -%% send_chunk_end(Pid) -> ok | {error, elogin} | {error, echunk} -%% | {error, econn} -%% Pid = pid() -%% -%% Description: End sending of chunks to remote file. -%%-------------------------------------------------------------------------- -send_chunk_end(Pid) -> - call(Pid, chunk_end, atom). - -%%-------------------------------------------------------------------------- -%% append_chunk_end(Pid) -> ok | {error, elogin} | {error, echunk} -%% | {error, econn} -%% Pid = pid() -%% -%% Description: End appending of chunks to remote file. -%%-------------------------------------------------------------------------- -append_chunk_end(Pid) -> - call(Pid, chunk_end, atom). - -%%-------------------------------------------------------------------------- -%% append(Pid, LocalFileName, RemotFileName) -> ok | {error, epath} -%% | {error, elogin} | {error, econn} -%% Pid = pid() -%% LocalFileName = RemotFileName = string() -%% -%% Description: Append the local file to the remote file -%%-------------------------------------------------------------------------- -append(Pid, LocalFileName) -> - append(Pid, LocalFileName, LocalFileName). - -append(Pid, LocalFileName, RemotFileName) -> - call(Pid, {append, LocalFileName, RemotFileName}, atom). - -%%-------------------------------------------------------------------------- -%% append_bin(Pid, Bin, RemoteFile) -> ok | {error, epath} | {error, elogin} -%% | {error, enotbinary} | {error, econn} -%% Pid = pid() -%% Bin = binary() -%% RemoteFile = string() -%% -%% Purpose: Append a binary to a remote file. -%%-------------------------------------------------------------------------- -append_bin(Pid, Bin, RemoteFile) when binary(Bin) -> - call(Pid, {append_bin, Bin, RemoteFile}, atom); -append_bin(_Pid, _Bin, _RemoteFile) -> - {error, enotbinary}. - -%%-------------------------------------------------------------------------- -%% quote(Pid, Cmd) -> ok -%% Pid = pid() -%% Cmd = string() -%% -%% Description: Send arbitrary ftp command. -%%-------------------------------------------------------------------------- -quote(Pid, Cmd) when list(Cmd) -> - call(Pid, {quote, Cmd}, atom). - -%%-------------------------------------------------------------------------- -%% close(Pid) -> ok -%% Pid = pid() -%% -%% Description: End the ftp session. -%%-------------------------------------------------------------------------- -close(Pid) -> - cast(Pid, close), - ok. - -%%-------------------------------------------------------------------------- -%% force_active(Pid) -> ok -%% Pid = pid() -%% -%% Description: Force connection to use active mode. -%%-------------------------------------------------------------------------- -force_active(Pid) -> - error_logger:info_report("This function is deprecated use the mode flag " - "to open/[1,2,3] instead", []), - call(Pid, force_active, atom). - -%%-------------------------------------------------------------------------- -%% formaterror(Tag) -> string() -%% Tag = atom() | {error, atom()} -%% -%% Description: Return diagnostics. -%%-------------------------------------------------------------------------- -formaterror(Tag) -> - ftp_response:error_string(Tag). - -%%%======================================================================== -%%% gen_server callback functions -%%%======================================================================== - -%%------------------------------------------------------------------------- -%% init(Args) -> {ok, State} | {ok, State, Timeout} | {stop, Reason} -%% Description: Initiates the erlang process that manages a ftp connection. -%%------------------------------------------------------------------------- -init([{client, ClientPid}, Flags]) -> - process_flag(trap_exit, true), - erlang:monitor(process, ClientPid), - inet_db:start(), - {ok, LDir} = file:get_cwd(), - State = case is_debug(Flags) or is_trace(Flags) of - true -> - dbg:tracer(), - dbg:p(all, [call]), - case is_debug(Flags) of - true -> - dbg:tp(ftp, [{'_', [], [{return_trace}]}]), - dbg:tp(ftp_response, [{'_', [], - [{return_trace}]}]), - dbg:tp(ftp_progress, [{'_', [], - [{return_trace}]}]); - false -> %trace - dbg:tpl(ftp, [{'_', [], [{return_trace}]}]), - dbg:tpl(ftp_response, [{'_', [], - [{return_trace}]}]), - dbg:tpl(ftp_progress, [{'_', [], - [{return_trace}]}]) - end, - #state{ldir = LDir}; - false -> - case is_verbose(Flags) of - true -> - #state{verbose = true, ldir = LDir}; - false -> - #state{ldir = LDir} - end - end, - process_flag(priority, low), - {ok, State#state{owner = ClientPid, - ip_v6_disabled = is_ipv6_disabled(Flags)}}. - - -%%-------------------------------------------------------------------------- -%% handle_call(Request, From, State) -> {reply, Reply, State} | -%% {reply, Reply, State, Timeout} | -%% {noreply, State} | -%% {noreply, State, Timeout} | -%% {stop, Reason, Reply, State} | -%% Description: Handle incoming requests. -%%------------------------------------------------------------------------- -handle_call({Pid, _}, _, #state{owner = Owner} = State) when Owner =/= Pid -> - {reply, {error, not_connection_owner}, State}; - -handle_call({_, {open, ip_comm, Opts}}, From, State) -> - case key_search(host, Opts, undefined) of - undefined -> - {stop, normal, {error, ehost}, State}; - Host -> - IsPosInt = fun(Int) when is_integer(Int), Int > 0 -> - true; - (_) -> - false - end, - - IsModeAtom = fun(active) -> - true; - (passive) -> - true; - (_) -> - false - end, - - Mode = check_option(IsModeAtom, - key_search(mode, Opts, ?DEFAULT_MODE), - ?DEFAULT_MODE), - Port = check_option(IsPosInt, key_search(port, Opts, ?FTP_PORT), - ?FTP_PORT), - Timeout = check_option(IsPosInt, key_search(timeout, Opts, - ?CONNECTION_TIMEOUT), - ?CONNECTION_TIMEOUT), - ProgressOptions = key_search(progress, Opts, ignore), - - setup_ctrl_connection(Host, Port, Timeout, - State#state{client = From, mode = Mode, - progress = - progress(ProgressOptions)}) - end; - -handle_call({_, force_active}, _, State) -> - {reply, ok, State#state{mode = active}}; - -handle_call({_, {user, User, Password}}, From, State) -> - handle_user(User, Password, "", State#state{client = From}); - -handle_call({_, {user, User, Password, Acc}}, From, State) -> - handle_user(User, Password, Acc, State#state{client = From}); - -handle_call({_, {account, Acc}}, From, State)-> - handle_user_account(Acc, State#state{client = From}); - -handle_call({_, pwd}, From, #state{chunk = false} = State) -> - send_ctrl_message(State, mk_cmd("PWD", [])), - activate_ctrl_connection(State), - {noreply, State#state{client = From, caller = pwd}}; - -handle_call({_, lpwd}, From, #state{ldir = LDir} = State) -> - {reply, {ok, LDir}, State#state{client = From}}; - -handle_call({_, {cd, Dir}}, From, #state{chunk = false} - = State) -> - send_ctrl_message(State, mk_cmd("CWD ~s", [Dir])), - activate_ctrl_connection(State), - {noreply, State#state{client = From, caller = cd}}; - -handle_call({_,{lcd, Dir}}, _From, #state{ldir = LDir0} = State) -> - LDir = filename:absname(Dir, LDir0), - case file:read_file_info(LDir) of %% FIX better check that LDir is a dir. - {ok, _ } -> - {reply, ok, State#state{ldir = LDir}}; - _ -> - {reply, {error, epath}, State} - end; - -handle_call({_, {dir, Len, Dir}}, {_Pid, _} = From, - #state{chunk = false} = State) -> - setup_data_connection(State#state{caller = {dir, Dir, Len}, - client = From}); -handle_call({_, {rename, CurrFile, NewFile}}, From, - #state{chunk = false} = State) -> - send_ctrl_message(State, mk_cmd("RNFR ~s", [CurrFile])), - activate_ctrl_connection(State), - {noreply, State#state{caller = {rename, NewFile}, client = From}}; - -handle_call({_, {delete, File}}, {_Pid, _} = From, - #state{chunk = false} = State) -> - send_ctrl_message(State, mk_cmd("DELE ~s", [File])), - activate_ctrl_connection(State), - {noreply, State#state{client = From}}; - -handle_call({_, {mkdir, Dir}}, From, #state{chunk = false} = State) -> - send_ctrl_message(State, mk_cmd("MKD ~s", [Dir])), - activate_ctrl_connection(State), - {noreply, State#state{client = From}}; - -handle_call({_,{rmdir, Dir}}, From, #state{chunk = false} = State) -> - send_ctrl_message(State, mk_cmd("RMD ~s", [Dir])), - activate_ctrl_connection(State), - {noreply, State#state{client = From}}; - -handle_call({_,{type, Type}}, From, #state{chunk = false} - = State) -> - case Type of - ascii -> - send_ctrl_message(State, mk_cmd("TYPE A", [])), - activate_ctrl_connection(State), - {noreply, State#state{caller = type, type = ascii, - client = From}}; - binary -> - send_ctrl_message(State, mk_cmd("TYPE I", [])), - activate_ctrl_connection(State), - {noreply, State#state{caller = type, type = binary, - client = From}}; - _ -> - {reply, {error, etype}, State} - end; - -handle_call({_,{recv, RemoteFile, LocalFile}}, From, - #state{chunk = false, ldir = LocalDir} = State) -> - progress_report({remote_file, RemoteFile}, State), - NewLocalFile = filename:absname(LocalFile, LocalDir), - - case file_open(NewLocalFile, write) of - {ok, Fd} -> - setup_data_connection(State#state{client = From, - caller = - {recv_file, - RemoteFile, Fd}}); - {error, _What} -> - {reply, {error, epath}, State} - end; - -handle_call({_, {recv_bin, RemoteFile}}, From, #state{chunk = false} = - State) -> - setup_data_connection(State#state{caller = {recv_bin, RemoteFile}, - client = From}); - -handle_call({_,{recv_chunk_start, RemoteFile}}, From, #state{chunk = false} - = State) -> - setup_data_connection(State#state{caller = {start_chunk_transfer, - "RETR", RemoteFile}, - client = From}); - -handle_call({_, recv_chunk}, _, #state{chunk = false} = State) -> - {reply, {error, "ftp:recv_chunk_start/2 not called"}, State}; - -handle_call({_, recv_chunk}, From, #state{chunk = true} = State) -> - activate_data_connection(State), - {noreply, State#state{client = From, caller = recv_chunk}}; - -handle_call({_, {send, LocalFile, RemoteFile}}, From, - #state{chunk = false, ldir = LocalDir} = State) -> - progress_report({local_file, filename:absname(LocalFile, LocalDir)}, - State), - setup_data_connection(State#state{caller = {transfer_file, - {"STOR", - LocalFile, RemoteFile}}, - client = From}); -handle_call({_, {append, LocalFile, RemoteFile}}, From, - #state{chunk = false} = State) -> - setup_data_connection(State#state{caller = {transfer_file, - {"APPE", - LocalFile, RemoteFile}}, - client = From}); -handle_call({_, {send_bin, Bin, RemoteFile}}, From, - #state{chunk = false} = State) -> - setup_data_connection(State#state{caller = {transfer_data, - {"STOR", Bin, RemoteFile}}, - client = From}); -handle_call({_,{append_bin, Bin, RemoteFile}}, From, - #state{chunk = false} = State) -> - setup_data_connection(State#state{caller = {transfer_data, - {"APPE", Bin, RemoteFile}}, - client = From}); -handle_call({_, {send_chunk_start, RemoteFile}}, From, #state{chunk = false} - = State) -> - setup_data_connection(State#state{caller = {start_chunk_transfer, - "STOR", RemoteFile}, - client = From}); -handle_call({_, {append_chunk_start, RemoteFile}}, From, #state{chunk = false} - = State) -> - setup_data_connection(State#state{caller = {start_chunk_transfer, - "APPE", RemoteFile}, - client = From}); -handle_call({_, {transfer_chunk, Bin}}, _, #state{chunk = true} = State) -> - send_data_message(State, Bin), - {reply, ok, State}; - -handle_call({_, chunk_end}, From, #state{chunk = true} = State) -> - close_data_connection(State), - activate_ctrl_connection(State), - {noreply, State#state{client = From, dsock = undefined, - caller = end_chunk_transfer, chunk = false}}; - -handle_call({_, {quote, Cmd}}, From, #state{chunk = false} = State) -> - send_ctrl_message(State, mk_cmd(Cmd, [])), - activate_ctrl_connection(State), - {noreply, State#state{client = From, caller = quote}}; - -handle_call(_, _, #state{chunk = true} = State) -> - {reply, {error, echunk}, State}; - -%% Catch all - This can only happen if the application programmer writes -%% really bad code that violates the API. -handle_call(Request, _Timeout, State) -> - {stop, {'API_violation_connection_closed', Request}, - {error, {connection_terminated, 'API_violation'}}, State}. - -%%-------------------------------------------------------------------------- -%% handle_cast(Request, State) -> {noreply, State} | -%% {noreply, State, Timeout} | -%% {stop, Reason, State} -%% Description: Handles cast messages. -%%------------------------------------------------------------------------- -handle_cast({Pid, close}, #state{owner = Pid} = State) -> - send_ctrl_message(State, mk_cmd("QUIT", [])), - close_ctrl_connection(State), - close_data_connection(State), - {stop, normal, State#state{csock = undefined, dsock = undefined}}; - -handle_cast({Pid, close}, State) -> - error_logger:info_report("A none owner process ~p tried to close an " - "ftp connection: ~n", [Pid]), - {noreply, State}; - -%% Catch all - This can oly happen if the application programmer writes -%% really bad code that violates the API. -handle_cast(Msg, State) -> - {stop, {'API_violation_connection_colsed', Msg}, State}. - -%%-------------------------------------------------------------------------- -%% handle_info(Msg, State) -> {noreply, State} | {noreply, State, Timeout} | -%% {stop, Reason, State} -%% Description: Handles tcp messages from the ftp-server. -%% Note: The order of the function clauses is significant. -%%-------------------------------------------------------------------------- - -handle_info(timeout, #state{caller = open} = State) -> - {stop, timeout, State}; - -handle_info(timeout, State) -> - {noreply, State}; - -%%% Data socket messages %%% -handle_info({tcp, Socket, Data}, - #state{dsock = Socket, - caller = {recv_file, Fd}} = State) -> - file_write(binary_to_list(Data), Fd), - progress_report({binary, Data}, State), - activate_data_connection(State), - {noreply, State}; - -handle_info({tcp, Socket, Data}, #state{dsock = Socket, client = From, - caller = recv_chunk} - = State) -> - gen_server:reply(From, {ok, Data}), - {noreply, State#state{client = undefined, data = <<>>}}; - -handle_info({tcp, Socket, Data}, #state{dsock = Socket} = State) -> - activate_data_connection(State), - {noreply, State#state{data = <<(State#state.data)/binary, - Data/binary>>}}; - -handle_info({tcp_closed, Socket}, #state{dsock = Socket, - caller = {recv_file, Fd}} - = State) -> - file_close(Fd), - progress_report({transfer_size, 0}, State), - activate_ctrl_connection(State), - {noreply, State#state{dsock = undefined, data = <<>>}}; - -handle_info({tcp_closed, Socket}, #state{dsock = Socket, client = From, - caller = recv_chunk} - = State) -> - gen_server:reply(From, ok), - {noreply, State#state{dsock = undefined, client = undefined, - data = <<>>, caller = undefined, - chunk = false}}; - -handle_info({tcp_closed, Socket}, #state{dsock = Socket, caller = recv_bin, - data = Data} = State) -> - activate_ctrl_connection(State), - {noreply, State#state{dsock = undefined, data = <<>>, - caller = {recv_bin, Data}}}; - -handle_info({tcp_closed, Socket}, #state{dsock = Socket, data = Data, - caller = {handle_dir_result, Dir}} - = State) -> - activate_ctrl_connection(State), - {noreply, State#state{dsock = undefined, - caller = {handle_dir_result, Dir, Data}, -% data = <<?CR,?LF>>}}; - data = <<>>}}; - -handle_info({tcp_error, Socket, Reason}, #state{dsock = Socket, - client = From} = State) -> - gen_server:reply(From, {error, Reason}), - close_data_connection(State), - {noreply, State#state{dsock = undefined, client = undefined, - data = <<>>, caller = undefined, chunk = false}}; - -%%% Ctrl socket messages %%% -handle_info({tcp, Socket, Data}, #state{csock = Socket, - verbose = Verbose, - caller = Caller, - client = From, - ctrl_data = {CtrlData, AccLines, - LineStatus}} - = State) -> - case ftp_response:parse_lines(<<CtrlData/binary, Data/binary>>, - AccLines, LineStatus) of - {ok, Lines, NextMsgData} -> - verbose(Lines, Verbose, 'receive'), - CtrlResult = ftp_response:interpret(Lines), - case Caller of - quote -> - gen_server:reply(From, string:tokens(Lines, [?CR, ?LF])), - {noreply, State#state{client = undefined, - caller = undefined, - ctrl_data = {NextMsgData, [], - start}}}; - _ -> - handle_ctrl_result(CtrlResult, - State#state{ctrl_data = - {NextMsgData, [], start}}) - end; - {continue, NewCtrlData} -> - activate_ctrl_connection(State), - {noreply, State#state{ctrl_data = NewCtrlData}} - end; - -handle_info({tcp_closed, Socket}, #state{csock = Socket}) -> - %% If the server closes the control channel it is - %% the expected behavior that connection process terminates. - exit(normal); %% User will get error message from terminate/2 - -handle_info({tcp_error, Socket, Reason}, _) -> - error_logger:error_report("tcp_error on socket: ~p for reason: ~p~n", - [Socket, Reason]), - %% If tcp does not work the only option is to terminate, - %% this is the expected behavior under these circumstances. - exit(normal); %% User will get error message from terminate/2 - -%% Monitor messages - if the process owning the ftp connection goes -%% down there is no point in continuing. -handle_info({'DOWN', _Ref, _Type, _Process, normal}, State) -> - {stop, normal, State#state{client = undefined}}; - -handle_info({'DOWN', _Ref, _Type, _Process, shutdown}, State) -> - {stop, normal, State#state{client = undefined}}; - -handle_info({'DOWN', _Ref, _Type, _Process, timeout}, State) -> - {stop, normal, State#state{client = undefined}}; - -handle_info({'DOWN', _Ref, _Type, Process, Reason}, State) -> - {stop, {stopped, {'EXIT', Process, Reason}}, - State#state{client = undefined}}; - -handle_info({'EXIT', Pid, Reason}, #state{progress = Pid} = State) -> - error_logger:info_report("Progress reporting stopped for reason ~p~n", - Reason), - {noreply, State#state{progress = ignore}}; - -%% Catch all - throws away unknown messages (This could happen by "accident" -%% so we do not want to crash, but we make a log entry as it is an -%% unwanted behaviour.) -handle_info(Info, State) -> - error_logger:info_report("ftp : ~p : Unexpected message: ~p\n", - [self(), Info]), - {noreply, State}. - -%%-------------------------------------------------------------------------- -%% terminate/2 and code_change/3 -%%-------------------------------------------------------------------------- -terminate(normal, State) -> - %% If terminate reason =/= normal the progress reporting process will - %% be killed by the exit signal. - progress_report(stop, State), - do_termiante({error, econn}, State); -terminate(Reason, State) -> - error_logger:error_report("Ftp connection closed due to: ~p~n", [Reason]), - do_termiante({error, eclosed}, State). - -do_termiante(ErrorMsg, State) -> - close_data_connection(State), - close_ctrl_connection(State), - case State#state.client of - undefined -> - ok; - From -> - gen_server:reply(From, ErrorMsg) - end, - ok. - -code_change(_, State, _) -> - {ok, State}. - -%%%========================================================================= -%% Start/stop -%%%========================================================================= -%%-------------------------------------------------------------------------- -%% start_link_sup([Args, Options]) -> {ok, Pid} | {error, Reason} -%% -%% Description: Callback function for the ftp supervisor. It is called -%% : when open/[1,3] calls ftp_sup:start_child/1 to start an -%% : instance of the ftp process. -%%-------------------------------------------------------------------------- -start_link_sup([Args, Options]) -> - gen_server:start_link(?MODULE, Args, Options). - -%%% Stop functionality is handled by close/1 - -%%%======================================================================== -%%% Internal functions -%%%======================================================================== - -%%-------------------------------------------------------------------------- -%%% Help functions to handle_call and/or handle_ctrl_result -%%-------------------------------------------------------------------------- -%% User handling -handle_user(User, Password, Acc, State) -> - send_ctrl_message(State, mk_cmd("USER ~s", [User])), - activate_ctrl_connection(State), - {noreply, State#state{caller = {handle_user, Password, Acc}}}. - -handle_user_passwd(Password, Acc, State) -> - send_ctrl_message(State, mk_cmd("PASS ~s", [Password])), - activate_ctrl_connection(State), - {noreply, State#state{caller = {handle_user_passwd, Acc}}}. - -handle_user_account(Acc, State) -> - send_ctrl_message(State, mk_cmd("ACCT ~s", [Acc])), - activate_ctrl_connection(State), - {noreply, State#state{caller = handle_user_account}}. - -%%-------------------------------------------------------------------------- -%% handle_ctrl_result -%%-------------------------------------------------------------------------- -%%-------------------------------------------------------------------------- -%% Handling of control connection setup -handle_ctrl_result({pos_compl, _}, #state{caller = open, client = From} - = State) -> - gen_server:reply(From, {ok, self()}), - {noreply, State#state{client = undefined, - caller = undefined }}; -handle_ctrl_result({_, Lines}, #state{caller = open} = State) -> - ctrl_result_response(econn, State, {error, Lines}); - -%%-------------------------------------------------------------------------- -%% Data connection setup active mode -handle_ctrl_result({pos_compl, _Lines}, - #state{mode = active, - caller = {setup_data_connection, - {LSock, Caller}}} = State) -> - handle_caller(State#state{caller = Caller, dsock = {lsock, LSock}}); - -handle_ctrl_result({Status, Lines}, - #state{mode = active, - caller = {setup_data_connection, {LSock, _}}} - = State) -> - close_connection(LSock), - ctrl_result_response(Status, State, {error, Lines}); - -%% Data connection setup passive mode -handle_ctrl_result({pos_compl, Lines}, #state{mode = passive, - ip_v6_disabled = false, - client=From, - caller = - {setup_data_connection, - Caller}, - csock = CSock, - timeout = Timeout} - = State) -> - [_, PortStr | _] = lists:reverse(string:tokens(Lines, "|")), - {ok, {IP, _}} = inet:peername(CSock), - case connect(IP, list_to_integer(PortStr), Timeout, State) of - {_,{ok, Socket}} -> - handle_caller(State#state{caller = Caller, dsock = Socket}); - {_,{error,Reason}} -> - gen_server:reply(From,{error,Reason}), - {noreply,State#state{client = undefined, caller = undefined}} - end; - -handle_ctrl_result({pos_compl, Lines}, - #state{mode = passive, ip_v6_disabled = true, - client=From, - caller = {setup_data_connection, Caller}, - timeout = Timeout} = State) -> - - {_, [?LEFT_PAREN | Rest]} = - lists:splitwith(fun(?LEFT_PAREN) -> false; (_) -> true end, Lines), - {NewPortAddr, _} = - lists:splitwith(fun(?RIGHT_PAREN) -> false; (_) -> true end, Rest), - [A1, A2, A3, A4, P1, P2] = lists:map(fun(X) -> list_to_integer(X) end, - string:tokens(NewPortAddr, [$,])), - case connect({A1, A2, A3, A4}, (P1 * 256) + P2, Timeout, State) of - {_,{ok,Socket}} -> - handle_caller(State#state{caller = Caller, dsock = Socket}); - {_,{error,Reason}} -> - gen_server:reply(From,{error,Reason}), - {noreply,State#state{client = undefined, caller = undefined}} - end; - -%% FTP server does not support passive mode try to fallback on active mode -handle_ctrl_result(_, #state{mode = passive, caller = {setup_data_connection, - Caller}} = State) -> - setup_data_connection(State#state{mode = active, caller = Caller}); - -%%-------------------------------------------------------------------------- -%% User handling -handle_ctrl_result({pos_interm, _}, #state{caller = - {handle_user, PassWord, Acc}} - = State) -> - handle_user_passwd(PassWord, Acc, State); -handle_ctrl_result({Status, _}, - #state{caller = {handle_user, _, _}} = State) -> - ctrl_result_response(Status, State, {error, euser}); - -%% Accounts -handle_ctrl_result({pos_interm_acct, _}, #state{caller = - {handle_user_passwd, Acc}} = - State) when Acc =/= "" -> - handle_user_account(Acc, State); -handle_ctrl_result({Status, _}, - #state{caller = {handle_user_passwd, _}} = State) -> - ctrl_result_response(Status, State, {error, euser}); - -%%-------------------------------------------------------------------------- -%% Print current working directory -handle_ctrl_result({pos_compl, Lines}, #state{caller = pwd, - client = From} = State) -> - Dir = pwd_result(Lines), - gen_server:reply(From, {ok, Dir}), - {noreply, State#state{client = undefined, caller = undefined}}; - -%%-------------------------------------------------------------------------- -%% Directory listing -handle_ctrl_result({pos_prel, _}, #state{caller = {dir, Dir}} = State) -> - NewState = accept_data_connection(State), - activate_data_connection(NewState), - {noreply, NewState#state{caller = {handle_dir_result, Dir}}}; - -handle_ctrl_result({pos_compl, _}, #state{caller = {handle_dir_result, Dir, - Data}, client = From} - = State) -> - case Dir of - "" -> % Current directory - gen_server:reply(From, {ok, Data}), - {noreply, State#state{client = undefined, - caller = undefined}}; - _ -> - %% If there is only one line it might be a directory with on - %% file but it might be an error message that the directory - %% was not found. So in this case we have to endure a little - %% overhead to be able to give a good return value. Alas not - %% all ftp implementations behave the same and returning - %% an error string is allowed by the FTP RFC. - case lists:dropwhile(fun(?CR) -> false;(_) -> true end, - binary_to_list(Data)) of - L when L == [?CR, ?LF]; L == [] -> - send_ctrl_message(State, mk_cmd("PWD", [])), - activate_ctrl_connection(State), - {noreply, - State#state{caller = {handle_dir_data, Dir, Data}}}; - _ -> - gen_server:reply(From, {ok, Data}), - {noreply, State#state{client = undefined, - caller = undefined}} - end - end; - -handle_ctrl_result({pos_compl, Lines}, - #state{caller = {handle_dir_data, Dir, DirData}} = - State) -> - OldDir = pwd_result(Lines), - send_ctrl_message(State, mk_cmd("CWD ~s", [Dir])), - activate_ctrl_connection(State), - {noreply, State#state{caller = {handle_dir_data_second_phase, OldDir, - DirData}}}; -handle_ctrl_result({Status, _}, - #state{caller = {handle_dir_data, _, _}} = State) -> - ctrl_result_response(Status, State, {error, epath}); - -handle_ctrl_result(S={_Status, _}, - #state{caller = {handle_dir_result, _, _}} = State) -> - %% OTP-5731, macosx - ctrl_result_response(S, State, {error, epath}); - -handle_ctrl_result({pos_compl, _}, - #state{caller = {handle_dir_data_second_phase, OldDir, - DirData}} = State) -> - send_ctrl_message(State, mk_cmd("CWD ~s", [OldDir])), - activate_ctrl_connection(State), - {noreply, State#state{caller = {handle_dir_data_third_phase, DirData}}}; -handle_ctrl_result({Status, _}, - #state{caller = {handle_dir_data_second_phase, _, _}} - = State) -> - ctrl_result_response(Status, State, {error, epath}); -handle_ctrl_result(_, #state{caller = {handle_dir_data_third_phase, DirData}, - client = From} = State) -> - gen_server:reply(From, {ok, DirData}), - {noreply, State#state{client = undefined, caller = undefined}}; - -handle_ctrl_result({Status, _}, #state{caller = cd} = State) -> - ctrl_result_response(Status, State, {error, epath}); - -handle_ctrl_result(Status={epath, _}, #state{caller = {dir,_}} = State) -> - ctrl_result_response(Status, State, {error, epath}); - -%%-------------------------------------------------------------------------- -%% File renaming -handle_ctrl_result({pos_interm, _}, #state{caller = {rename, NewFile}} - = State) -> - send_ctrl_message(State, mk_cmd("RNTO ~s", [NewFile])), - activate_ctrl_connection(State), - {noreply, State#state{caller = rename_second_phase}}; - -handle_ctrl_result({Status, _}, - #state{caller = {rename, _}} = State) -> - ctrl_result_response(Status, State, {error, epath}); - -handle_ctrl_result({Status, _}, - #state{caller = rename_second_phase} = State) -> - ctrl_result_response(Status, State, {error, epath}); - -%%-------------------------------------------------------------------------- -%% File handling - recv_bin -handle_ctrl_result({pos_prel, _}, #state{caller = recv_bin} = State) -> - NewState = accept_data_connection(State), - activate_data_connection(NewState), - {noreply, NewState}; - -handle_ctrl_result({pos_compl, _}, #state{caller = {recv_bin, Data}, - client = From} = State) -> - gen_server:reply(From, {ok, Data}), - close_data_connection(State), - {noreply, State#state{client = undefined, caller = undefined}}; - -handle_ctrl_result({Status, _}, #state{caller = recv_bin} = State) -> - close_data_connection(State), - ctrl_result_response(Status, State#state{dsock = undefined}, - {error, epath}); - -handle_ctrl_result({Status, _}, #state{caller = {recv_bin, _}} = State) -> - close_data_connection(State), - ctrl_result_response(Status, State#state{dsock = undefined}, - {error, epath}); -%%-------------------------------------------------------------------------- -%% File handling - start_chunk_transfer -handle_ctrl_result({pos_prel, _}, #state{client = From, - caller = start_chunk_transfer} - = State) -> - NewState = accept_data_connection(State), - gen_server:reply(From, ok), - {noreply, NewState#state{chunk = true, client = undefined, - caller = undefined}}; -%%-------------------------------------------------------------------------- -%% File handling - recv_file -handle_ctrl_result({pos_prel, _}, #state{caller = {recv_file, _}} = State) -> - NewState = accept_data_connection(State), - activate_data_connection(NewState), - {noreply, NewState}; - -handle_ctrl_result({Status, _}, #state{caller = {recv_file, Fd}} = State) -> - file_close(Fd), - close_data_connection(State), - ctrl_result_response(Status, State#state{dsock = undefined}, - {error, epath}); -%%-------------------------------------------------------------------------- -%% File handling - transfer_* -handle_ctrl_result({pos_prel, _}, #state{caller = {transfer_file, Fd}} - = State) -> - NewState = accept_data_connection(State), - send_file(Fd, NewState); - -handle_ctrl_result({pos_prel, _}, #state{caller = {transfer_data, Bin}} - = State) -> - NewState = accept_data_connection(State), - send_data_message(NewState, Bin), - close_data_connection(NewState), - activate_ctrl_connection(NewState), - {noreply, NewState#state{caller = transfer_data_second_phase, - dsock = undefined}}; -%%-------------------------------------------------------------------------- -%% Default -handle_ctrl_result({Status, Lines}, #state{client = From} = State) - when From =/= undefined -> - ctrl_result_response(Status, State, {error, Lines}). - -%%-------------------------------------------------------------------------- -%% Help functions to handle_ctrl_result -%%-------------------------------------------------------------------------- -ctrl_result_response(pos_compl, #state{client = From} = State, _) -> - gen_server:reply(From, ok), - {noreply, State#state{client = undefined, caller = undefined}}; - -ctrl_result_response(Status, #state{client = From} = State, _) when -Status == etnospc; Status == epnospc; Status == efnamena; Status == econn -> -%Status == etnospc; Status == epnospc; Status == econn -> - gen_server:reply(From, {error, Status}), -%% {stop, normal, {error, Status}, State#state{client = undefined}}; - {stop, normal, State#state{client = undefined}}; - -ctrl_result_response(_, #state{client = From} = State, ErrorMsg) -> - gen_server:reply(From, ErrorMsg), - {noreply, State#state{client = undefined, caller = undefined}}. - -%%-------------------------------------------------------------------------- -handle_caller(#state{caller = {dir, Dir, Len}} = State) -> - Cmd = case Len of - short -> "NLST"; - long -> "LIST" - end, - case Dir of - "" -> - send_ctrl_message(State, mk_cmd(Cmd, "")); - _ -> - send_ctrl_message(State, mk_cmd(Cmd ++ " ~s", [Dir])) - end, - activate_ctrl_connection(State), - {noreply, State#state{caller = {dir, Dir}}}; - -handle_caller(#state{caller = {recv_bin, RemoteFile}} = State) -> - send_ctrl_message(State, mk_cmd("RETR ~s", [RemoteFile])), - activate_ctrl_connection(State), - {noreply, State#state{caller = recv_bin}}; - -handle_caller(#state{caller = {start_chunk_transfer, Cmd, RemoteFile}} = - State) -> - send_ctrl_message(State, mk_cmd("~s ~s", [Cmd, RemoteFile])), - activate_ctrl_connection(State), - {noreply, State#state{caller = start_chunk_transfer}}; - -handle_caller(#state{caller = {recv_file, RemoteFile, Fd}} = State) -> - send_ctrl_message(State, mk_cmd("RETR ~s", [RemoteFile])), - activate_ctrl_connection(State), - {noreply, State#state{caller = {recv_file, Fd}}}; - -handle_caller(#state{caller = {transfer_file, {Cmd, LocalFile, RemoteFile}}, - ldir = LocalDir, client = From} = State) -> - case file_open(filename:absname(LocalFile, LocalDir), read) of - {ok, Fd} -> - send_ctrl_message(State, mk_cmd("~s ~s", [Cmd, RemoteFile])), - activate_ctrl_connection(State), - {noreply, State#state{caller = {transfer_file, Fd}}}; - {error, _} -> - gen_server:reply(From, {error, epath}), - {noreply, State#state{client = undefined, caller = undefined, - dsock = undefined}} - end; - -handle_caller(#state{caller = {transfer_data, {Cmd, Bin, RemoteFile}}} = - State) -> - send_ctrl_message(State, mk_cmd("~s ~s", [Cmd, RemoteFile])), - activate_ctrl_connection(State), - {noreply, State#state{caller = {transfer_data, Bin}}}. - -%% ----------- FTP SERVER COMMUNICATION ------------------------- - -%% Connect to FTP server at Host (default is TCP port 21) -%% in order to establish a control connection. -setup_ctrl_connection(Host, Port, Timeout, State)-> - MsTime = millisec_time(), - case connect(Host, Port, Timeout, State) of - {Ipv, {ok, CSock}} -> - NewState = - case Ipv of - ipv4 -> - State#state{csock = CSock, ip_v6_disabled = true}; - ipv6 -> - State#state{csock = CSock} - end, - activate_ctrl_connection(NewState), - case Timeout - (millisec_time() - MsTime) of - Timeout2 when (Timeout2 >= 0) -> - {noreply, NewState#state{caller = open}, Timeout2}; - _ -> - %% Oups: Simulate timeout - self() ! timeout, - {noreply, NewState#state{caller = open}} - end; - {_,{error, _}} -> - gen_server:reply(State#state.client, {error, ehost}), - {stop, normal, State#state{client = undefined}} - end. - -setup_data_connection(#state{mode = active, - caller = Caller, - csock = CSock} = State) -> - IntToString = fun(Element) -> integer_to_list(Element) end, - - case (catch inet:sockname(CSock)) of - {ok, {{_, _, _, _, _, _, _, _} = IP, _}} -> - {ok, LSock} = - gen_tcp:listen(0, [{ip, IP}, {active, false}, - inet6, binary, {packet, 0}]), - {ok, Port} = inet:port(LSock), - Cmd = mk_cmd("EPRT |2|~s:~s:~s:~s:~s:~s:~s:~s|~s|", - lists:map(IntToString, - tuple_to_list(IP) ++ [Port])), - send_ctrl_message(State, Cmd), - activate_ctrl_connection(State), - {noreply, State#state{caller = {setup_data_connection, - {LSock, Caller}}}}; - {ok, {{_,_,_,_} = IP, _}} -> - {ok, LSock} = gen_tcp:listen(0, [{ip, IP}, {active, false}, - binary, {packet, 0}]), - {ok, Port} = inet:port(LSock), - {IP1, IP2, IP3, IP4} = IP, - {Port1, Port2} = {Port div 256, Port rem 256}, - send_ctrl_message(State, - mk_cmd("PORT ~w,~w,~w,~w,~w,~w", - [IP1, IP2, IP3, IP4, Port1, Port2])), - activate_ctrl_connection(State), - {noreply, State#state{caller = {setup_data_connection, - {LSock, Caller}}}} - end; - -setup_data_connection(#state{mode = passive, ip_v6_disabled = false, - caller = Caller} = State) -> - send_ctrl_message(State, mk_cmd("EPSV", [])), - activate_ctrl_connection(State), - {noreply, State#state{caller = {setup_data_connection, Caller}}}; - -setup_data_connection(#state{mode = passive, ip_v6_disabled = true, - caller = Caller} = State) -> - send_ctrl_message(State, mk_cmd("PASV", [])), - activate_ctrl_connection(State), - {noreply, State#state{caller = {setup_data_connection, Caller}}}. - -connect(Host = {_,_,_,_}, Port, TimeOut, _) -> - {ipv4, gen_tcp:connect(Host, Port,[binary, {packet, 0}, {active, false}] , - TimeOut)}; -connect(Host = {_,_,_,_,_,_,_,_}, Port, TimeOut, - #state{ip_v6_disabled = false}) -> - {ipv6, gen_tcp:connect(Host, Port, - [binary, {packet, 0}, {active, false}, inet6], - TimeOut)}; -connect(Host, Port, TimeOut, #state{ip_v6_disabled = false}) -> - {Opts, NewHost, Ipv} = - case (inet:getaddr(Host, inet6)) of - %% If an ipv4-mapped ipv6 address is returned - %% use ipv4 directly as some ftp-servers does not - %% handle "ip4-ipv6-compatiblity" mode well! - {ok, IP = {0, 0, 0, 0, 0, 16#ffff, _, _}} -> - case inet:getaddr(Host, inet) of - {ok,NewIP} -> - {[binary, {packet, 0}, {active, false}], NewIP, ipv4}; - _Error -> - {[binary, {packet, 0}, {active, false}, inet6], - IP,ipv6} - end; - {ok, IP} -> - {[binary, {packet, 0}, {active, false}, inet6], IP, ipv6}; - {error, _} -> - {[binary, {packet, 0}, {active, false}], Host, ipv4} - end, - {Ipv, gen_tcp:connect(NewHost, Port, Opts, TimeOut)}; - -connect(Host, Port, TimeOut, #state{ip_v6_disabled = true}) -> - Opts = [binary, {packet, 0}, {active, false}], - {ipv4, gen_tcp:connect(Host, Port, Opts, TimeOut)}. - -accept_data_connection(#state{mode = active, - dsock = {lsock, LSock}} = State) -> - {ok, Socket} = gen_tcp:accept(LSock), - gen_tcp:close(LSock), - State#state{dsock = Socket}; - -accept_data_connection(#state{mode = passive} = State) -> - State. - -send_ctrl_message(#state{csock = Socket,verbose=Verbose}, Message) -> -% io:format("Sending: ~p~n",[Message]), - verbose(lists:flatten(Message),Verbose,send), - send_message(Socket, Message). - -send_data_message(#state{dsock = Socket}, Message) -> - send_message(Socket, Message). - -send_message(Socket, Message) -> - case gen_tcp:send(Socket, Message) of - ok -> - ok; - {error, Reason} -> - error_logger:error_report("gen_tcp:send/2 failed for " - "reason ~p~n", [Reason]), - %% If tcp does not work the only option is to terminate, - %% this is the expected behavior under these circumstances. - exit(normal) %% User will get error message from terminate/2 - end. - -activate_ctrl_connection(#state{csock = Socket, ctrl_data = {<<>>, _, _}}) -> - activate_connection(Socket); -activate_ctrl_connection(#state{csock = Socket}) -> - %% We have already received at least part of the next control message, - %% that has been saved in ctrl_data, process this first. - self() ! {tcp, Socket, <<>>}. - -activate_data_connection(#state{dsock = Socket}) -> - activate_connection(Socket). - -activate_connection(Socket) -> - inet:setopts(Socket, [{active, once}]). - -close_ctrl_connection(#state{csock = undefined}) -> - ok; -close_ctrl_connection(#state{csock = Socket}) -> - close_connection(Socket). - -close_data_connection(#state{dsock = undefined}) -> - ok; -close_data_connection(#state{dsock = {lsock, Socket}}) -> - close_connection(Socket); -close_data_connection(#state{dsock = Socket}) -> - close_connection(Socket). - -close_connection(Socket) -> - gen_tcp:close(Socket). - -%% ------------ FILE HANDELING ---------------------------------------- - -send_file(Fd, State) -> - case file_read(Fd) of - {ok, N, Bin} when N > 0-> - send_data_message(State, Bin), - progress_report({binary, Bin}, State), - send_file(Fd, State); - {ok, _, _} -> - file_close(Fd), - close_data_connection(State), - progress_report({transfer_size, 0}, State), - activate_ctrl_connection(State), - {noreply, State#state{caller = transfer_file_second_phase, - dsock = undefined}}; - {error, Reason} -> - gen_server:reply(State#state.client, {error, Reason}), - {stop, normal, State#state{client = undefined}} - end. - -file_open(File, Option) -> - file:open(File, [raw, binary, Option]). - -file_close(Fd) -> - file:close(Fd). - -file_read(Fd) -> - case file:read(Fd, ?FILE_BUFSIZE) of - {ok, Bytes} -> - {ok, size(Bytes), Bytes}; - eof -> - {ok, 0, []}; - Other -> - Other - end. - -file_write(Bytes, Fd) -> - file:write(Fd, Bytes). - -%% -------------- MISC ---------------------------------------------- - -call(GenServer, Msg, Format) -> - call(GenServer, Msg, Format, infinity). -call(GenServer, Msg, Format, Timeout) -> - - Result = (catch gen_server:call(GenServer, {self(), Msg}, Timeout)), - - case Result of - {ok, Bin} when binary(Bin), Format == string -> - {ok, binary_to_list(Bin)}; - {'EXIT', _} -> - {error, eclosed}; - Result -> - Result - end. - -cast(GenServer, Msg) -> - gen_server:cast(GenServer, {self(), Msg}). - -mk_cmd(Fmt, Args) -> - [io_lib:format(Fmt, Args)| [?CR, ?LF]]. % Deep list ok. - -pwd_result(Lines) -> - {_, [?DOUBLE_QUOTE | Rest]} = - lists:splitwith(fun(?DOUBLE_QUOTE) -> false; (_) -> true end, Lines), - {Dir, _} = - lists:splitwith(fun(?DOUBLE_QUOTE) -> false; (_) -> true end, Rest), - Dir. - -is_verbose(Params) -> - check_param(verbose, Params). - -is_debug(Flags) -> - check_param(debug, Flags). - -is_trace(Flags) -> - check_param(trace, Flags). - -is_ipv6_disabled(Flags) -> - check_param(ip_v6_disabled, Flags). - -check_param(Param, Params) -> - lists:member(Param, Params). - -key_search(Key, List, Default)-> - case lists:keysearch(Key, 1, List) of - {value, {_,Val}} -> - Val; - false -> - Default - end. - -check_option(Pred, Value, Default) -> - case Pred(Value) of - true -> - Value; - false -> - Default - end. - -verbose(Lines, true, Direction) -> - DirStr = - case Direction of - send -> - "Sending: "; - _ -> - "Receiving: " - end, - Str = string:strip(string:strip(Lines, right, ?LF), right, ?CR), - erlang:display(DirStr++Str); -verbose(_, false,_) -> - ok. - -ensure_started() -> - %% Start of the inets application should really be handled by the - %% application using inets. - case application:start(inets) of - {error,{already_started,inets}} -> - ok; - {error,{{already_started, _}, % Started as an included application - {inets_app,start, _}}} -> - ok; - ok -> - error_logger:info_report("The inets application was not started." - " Has now been started as a temporary" - " application.") - end. - -progress(Options) -> - ftp_progress:start_link(Options). - -progress_report(_, #state{progress = ignore}) -> - ok; -progress_report(stop, #state{progress = ProgressPid}) -> - ftp_progress:stop(ProgressPid); -progress_report({binary, Data}, #state{progress = ProgressPid}) -> - ftp_progress:report(ProgressPid, {transfer_size, size(Data)}); -progress_report(Report, #state{progress = ProgressPid}) -> - ftp_progress:report(ProgressPid, Report). - - -millisec_time() -> - {A,B,C} = erlang:now(), - A*1000000000+B*1000+(C div 1000). diff --git a/src/couch_inets/ftp_internal.hrl b/src/couch_inets/ftp_internal.hrl deleted file mode 100644 index eb605af9..00000000 --- a/src/couch_inets/ftp_internal.hrl +++ /dev/null @@ -1,19 +0,0 @@ -%% ``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$ -%% - --include("inets_internal.hrl"). diff --git a/src/couch_inets/ftp_progress.erl b/src/couch_inets/ftp_progress.erl deleted file mode 100644 index 1b3c1072..00000000 --- a/src/couch_inets/ftp_progress.erl +++ /dev/null @@ -1,125 +0,0 @@ -%% ``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$ -%% -%% Description: This module impements a temporary process that -%% performes progress reporting during file transfer calling a user -%% defined callback function. Its life span is as long as the ftp connection -%% processes that spawned it lives. The purpose of this process is to -%% shild the ftp connection process from errors and time consuming operations -%% in the user defined callback function. - --module(ftp_progress). - -%% Internal API --export([start_link/1, report/2, stop/1]). - -%% Spawn export --export([init/1]). - --include_lib("kernel/include/file.hrl"). - --record(progress, { - file, % string() - cb_module, % atom() - cb_function, % atom() - init_progress_term, % term() - current_progress_term % term() - }). - -%%%========================================================================= -%%% Internal application API -%%%========================================================================= -%%-------------------------------------------------------------------------- -%% start_link(Options) -> ignore | pid() -%% Options = ignore | {CBModule, CBFunction, InitProgressTerm} -%% -%% Description: Starts the progress report process unless progress reporting -%% should not be performed. -%%-------------------------------------------------------------------------- -start_link(ignore) -> - ignore; -start_link(Options) -> - spawn_link(?MODULE, init, [Options]). - -%%-------------------------------------------------------------------------- -%% report_progress(Pid, Report) -> _ -%% Pid = pid() -%% Report = {local_file, File} | {remote_file, File} | -%% {transfer_size, Size} -%% Size = integer() -%% -%% Description: Reports progress to the reporting process that calls the -%% user defined callback function. -%%-------------------------------------------------------------------------- -report(Pid, Report) -> - Pid ! {progress_report, Report}. - -%%-------------------------------------------------------------------------- -%% stop(Pid) -> _ -%% Pid = pid() -%% -%% Description: -%%-------------------------------------------------------------------------- -stop(Pid) -> - Pid ! stop. - -%%%========================================================================= -%%% Internal functions -%%%========================================================================= -init(Options) -> - loop(progress(Options)). - -loop(Progress) -> - receive - {progress_report, Report} -> - NewProgress = report_progress(Report, Progress), - loop(NewProgress); - stop -> - ok - end. - -progress({CBModule, CBFunction, InitProgressTerm}) when is_atom(CBModule), - is_atom(CBFunction) -> - #progress{cb_module = CBModule, - cb_function = CBFunction, - init_progress_term = InitProgressTerm, - current_progress_term = InitProgressTerm}. - -report_progress({local_file, File}, Progress) -> - {ok, FileInfo} = file:read_file_info(File), - report_progress({file_size, FileInfo#file_info.size}, - Progress#progress{file = File}); - -report_progress({remote_file, File}, Progress) -> - report_progress({file_size, unknown}, Progress#progress{file = File}); - -report_progress(Size, #progress{file = File, - cb_module = CBModule, - cb_function = CBFunction, - current_progress_term = Term, - init_progress_term = InitTerm} = Progress) -> - - NewProgressTerm = CBModule:CBFunction(Term, File, Size), - - case Size of - {transfer_size, 0} -> - %% Transfer is compleat reset initial values - Progress#progress{current_progress_term = InitTerm, - file = undefined}; - _ -> - Progress#progress{current_progress_term = NewProgressTerm} - end. diff --git a/src/couch_inets/ftp_response.erl b/src/couch_inets/ftp_response.erl deleted file mode 100644 index 55e745c4..00000000 --- a/src/couch_inets/ftp_response.erl +++ /dev/null @@ -1,190 +0,0 @@ -%% ``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$ -%% -%% Description: This module impements handling of ftp server responses. - --module(ftp_response). - -%% Internal API --export([parse_lines/3, interpret/1, error_string/1]). - --include("ftp_internal.hrl"). - -%% 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). - -%%%========================================================================= -%%% INTERNAL API -%%%========================================================================= - -%%-------------------------------------------------------------------------- -%% parse_lines(Data, AccLines, StatusCode) -> {ok, Lines} | -%% {continue, {Data, -%% AccLines, StatusCode}} -%% -%% Data = binary() - data recived on the control connection from the -%% ftp-server. -%% AccLines = [string()] -%% StatusCode = start | {byte(), byte(), byte()} | finish - -%% Indicates where in the parsing process we are. -%% start - (looking for the status code of the message) -%% {byte(), byte(), byte()} - status code found, now -%% looking for the last line indication. -%% finish - now on the last line. -%% Description: Parses a ftp control response message. -%% "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 (CRLF), or a so called multilined reply 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 -%% will pad the front to avoid confusion. -%%-------------------------------------------------------------------------- - -%% Make sure we received the first 4 bytes so we know how to parse -%% the FTP server response e.i. is the response composed of one -%% or multiple lines. -parse_lines(Bin, Lines, start) when size(Bin) < 4 -> - {continue, {Bin, Lines, start}}; -%% Multiple lines exist -parse_lines(<<C1, C2, C3, $-, Rest/binary>>, Lines, start) -> - parse_lines(Rest, [$-, C3, C2, C1 | Lines], {C1, C2, C3}); -%% Only one line exists -parse_lines(<<C1, C2, C3, ?WHITE_SPACE, Bin/binary>>, Lines, start) -> - parse_lines(Bin, [?WHITE_SPACE, C3, C2, C1 | Lines], finish); - -%% Last line found -parse_lines(<<C1, C2, C3, ?WHITE_SPACE, Rest/binary>>, Lines, {C1, C2, C3}) -> - parse_lines(Rest, [?WHITE_SPACE, C3, C2, C1 | Lines], finish); -%% Potential end found wait for more data -parse_lines(<<C1, C2, C3>> = Bin, Lines, {C1, C2, C3}) -> - {continue, {Bin, Lines, {C1, C2, C3}}}; -%% Intermidate line begining with status code -parse_lines(<<C1, C2, C3, Rest/binary>>, Lines, {C1, C2, C3}) -> - parse_lines(Rest, [C3, C2, C1 | Lines], {C1, C2, C3}); - -%% Potential last line wait for more data -parse_lines(<<C1, C2>> = Data, Lines, {C1, C2, _} = StatusCode) -> - {continue, {Data, Lines, StatusCode}}; -parse_lines(<<C1>> = Data, Lines, {C1, _, _} = StatusCode) -> - {continue, {Data, Lines, StatusCode}}; -parse_lines(<<>> = Data, Lines, {_,_,_} = StatusCode) -> - {continue, {Data, Lines, StatusCode}}; -%% Part of the multiple lines -parse_lines(<<Octet, Rest/binary>>, Lines, {_,_, _} = StatusCode) -> - parse_lines(Rest, [Octet | Lines], StatusCode); - -%% End of FTP server response found -parse_lines(<<?CR, ?LF>>, Lines, finish) -> - {ok, lists:reverse([?LF, ?CR | Lines]), <<>>}; -parse_lines(<<?CR, ?LF, Rest/binary>>, Lines, finish) -> - {ok, lists:reverse([?LF, ?CR | Lines]), Rest}; - -%% Potential end found wait for more data -parse_lines(<<?CR>> = Data, Lines, finish) -> - {continue, {Data, Lines, finish}}; -parse_lines(<<>> = Data, Lines, finish) -> - {continue, {Data, Lines, finish}}; -%% Part of last line -parse_lines(<<Octet, Rest/binary>>, Lines, finish) -> - parse_lines(Rest, [Octet | Lines], finish). - -%%-------------------------------------------------------------------------- -%% interpret(Lines) -> {Status, Text} -%% Lines = [byte(), byte(), byte() | Text] - ftp server response as -%% returned by parse_lines/3 -%% Stauts = atom() (see interpret_status/3) -%% Text = [string()] -%% -%% Description: Create nicer data to match on. -%%-------------------------------------------------------------------------- -interpret([Didgit1, Didgit2, Didgit3 | Data]) -> - Code1 = Didgit1 - $0, - Code2 = Didgit2 - $0, - Code3 = Didgit3 - $0, - {interpret_status(Code1, Code2, Code3), Data}. - -%%-------------------------------------------------------------------------- -%% error_string(Error) -> string() -%% Error = {error, term()} | term() -%% -%% Description: Translates error codes into strings intended for -%% human interpretation. -%%-------------------------------------------------------------------------- -error_string({error, Reason}) -> - error_string(Reason); - -error_string(echunk) -> "Synchronisation error during chunk sending."; -error_string(eclosed) -> "Session has been closed."; -error_string(econn) -> "Connection to remote server prematurely closed."; -error_string(eexists) ->"File or directory already exists."; -error_string(ehost) -> "Host not found, FTP server not found, " - "or connection rejected."; -error_string(elogin) -> "User not logged in."; -error_string(enotbinary) -> "Term is not a binary."; -error_string(epath) -> "No such file or directory, already exists, " - "or permission denied."; -error_string(etype) -> "No such type."; -error_string(euser) -> "User name or password not valid."; -error_string(etnospc) -> "Insufficient storage space in system."; -error_string(epnospc) -> "Exceeded storage allocation " - "(for current directory or dataset)."; -error_string(efnamena) -> "File name not allowed."; -error_string(Reason) -> - lists:flatten(io_lib:format("Unknown error: ~w", [Reason])). - -%%%======================================================================== -%%% Internal functions -%%%======================================================================== - -%% Positive Preleminary Reply -interpret_status(?POS_PREL,_,_) -> pos_prel; -%% Positive Completion Reply -interpret_status(?POS_COMPL,_,_) -> pos_compl; -%% Positive Intermediate Reply nedd account -interpret_status(?POS_INTERM,?AUTH_ACC,2) -> pos_interm_acct; -%% Positive Intermediate Reply -interpret_status(?POS_INTERM,_,_) -> pos_interm; -%% No storage area no action taken -interpret_status(?TRANS_NEG_COMPL,?FILE_SYSTEM,2) -> etnospc; -%% Temporary Error, no action taken -interpret_status(?TRANS_NEG_COMPL,_,_) -> trans_neg_compl; -%% Permanent disk space error, the user shall not try again -interpret_status(?PERM_NEG_COMPL,?FILE_SYSTEM,0) -> epath; -interpret_status(?PERM_NEG_COMPL,?FILE_SYSTEM,2) -> epnospc; -interpret_status(?PERM_NEG_COMPL,?FILE_SYSTEM,3) -> efnamena; -interpret_status(?PERM_NEG_COMPL,_,_) -> perm_neg_compl. - diff --git a/src/couch_inets/ftp_sup.erl b/src/couch_inets/ftp_sup.erl deleted file mode 100644 index c564fb0b..00000000 --- a/src/couch_inets/ftp_sup.erl +++ /dev/null @@ -1,57 +0,0 @@ -%% ``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$ -%% -%%---------------------------------------------------------------------- -%% Purpose: The top supervisor for the ftp hangs under inets_sup. -%%---------------------------------------------------------------------- --module(ftp_sup). - --behaviour(supervisor). - -%% API --export([start_link/0]). --export([start_child/1]). - -%% Supervisor callback --export([init/1]). - -%%%========================================================================= -%%% API -%%%========================================================================= -start_link() -> - supervisor:start_link({local, ?MODULE}, ?MODULE, []). - -start_child(Args) -> - supervisor:start_child(?MODULE, Args). - -%%%========================================================================= -%%% Supervisor callback -%%%========================================================================= -init(_) -> - RestartStrategy = simple_one_for_one, - MaxR = 0, - MaxT = 3600, - - Name = undefined, % As simple_one_for_one is used. - StartFunc = {ftp, start_link_sup, []}, - Restart = temporary, % E.g. should not be restarted - Shutdown = 4000, - Modules = [ftp], - Type = worker, - - ChildSpec = {Name, StartFunc, Restart, Shutdown, Type, Modules}, - {ok, {{RestartStrategy, MaxR, MaxT}, [ChildSpec]}}. diff --git a/src/couch_inets/http.erl b/src/couch_inets/http.erl deleted file mode 100644 index bdc7f73a..00000000 --- a/src/couch_inets/http.erl +++ /dev/null @@ -1,396 +0,0 @@ -% ``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$ -%% -%% This module is very loosely based on code initially developed by -%% Johan Blom at Mobile Arts AB -%% Description: -%%% This version of the HTTP/1.1 client supports: -%%% - RFC 2616 HTTP 1.1 client part -%%% - RFC 2818 HTTP Over TLS - --module(http). - -%% API --export([request/1, request/4, cancel_request/1, set_options/1, - verify_cookies/2, cookie_header/1]). - --include("http_internal.hrl"). --include("httpc_internal.hrl"). - -%%%========================================================================= -%%% API -%%%========================================================================= - -%%-------------------------------------------------------------------------- -%% request(Method, Request, HTTPOptions, Options) -> -%% {ok, {StatusLine, Headers, Body}} | {ok, {Status, Body}} | -%% {ok, RequestId} | {error,Reason} | {ok, {saved_as, FilePath} -%% -%% Method - atom() = head | get | put | post | trace | options| delete -%% Request - {Url, Headers} | {Url, Headers, ContentType, Body} -%% Url - string() -%% HTTPOptions - [HttpOption] -%% HTTPOption - {timeout, Time} | {ssl, SSLOptions} | -%% {proxy_auth, {User, Password}} -%% Ssloptions = [SSLOption] -%% SSLOption = {verify, code()} | {depth, depth()} | {certfile, path()} | -%% {keyfile, path()} | {password, string()} | {cacertfile, path()} | -%% {ciphers, string()} -%% Options - [Option] -%% Option - {sync, Boolean} | {body_format, BodyFormat} | -%% {full_result, Boolean} | {stream, To} | -%% {headers_as_is, Boolean} -%% StatusLine = {HTTPVersion, StatusCode, ReasonPhrase}</v> -%% HTTPVersion = string() -%% StatusCode = integer() -%% ReasonPhrase = string() -%% Headers = [Header] -%% Header = {Field, Value} -%% Field = string() -%% Value = string() -%% Body = string() | binary() - HTLM-code -%% -%% Description: Sends a HTTP-request. The function can be both -%% syncronus and asynchronous in the later case the function will -%% return {ok, RequestId} and later on a message will be sent to the -%% calling process on the format {http, {RequestId, {StatusLine, -%% Headers, Body}}} or {http, {RequestId, {error, Reason}}} -%% %%-------------------------------------------------------------------------- -request(Url) -> - request(get, {Url, []}, [], []). - -request(Method, {Url, Headers}, HTTPOptions, Options) - when Method==options;Method==get;Method==head;Method==delete;Method==trace -> - case http_uri:parse(Url) of - {error,Reason} -> - {error,Reason}; - ParsedUrl -> - handle_request(Method, Url, {ParsedUrl, Headers, [], []}, - HTTPOptions, Options) - end; - -request(Method, {Url,Headers,ContentType,Body}, HTTPOptions, Options) - when Method==post;Method==put -> - case http_uri:parse(Url) of - {error,Reason} -> - {error,Reason}; - ParsedUrl -> - handle_request(Method, Url, - {ParsedUrl, Headers, ContentType, Body}, - HTTPOptions, Options) - end. - -%%-------------------------------------------------------------------------- -%% request(RequestId) -> ok -%% RequestId - As returned by request/4 -%% -%% Description: Cancels a HTTP-request. -%%------------------------------------------------------------------------- -cancel_request(RequestId) -> - ok = httpc_manager:cancel_request(RequestId), - receive - %% If the request was allready fullfilled throw away the - %% answer as the request has been canceled. - {http, {RequestId, _}} -> - ok - after 0 -> - ok - end. - -%%-------------------------------------------------------------------------- -%% set_options(Options) -> -%% Options - [Option] -%% Option - {proxy, {Proxy, NoProxy}} | {max_sessions, MaxSessions} | -%% {max_pipeline_length, MaxPipeline} | -%% {pipeline_timeout, PipelineTimeout} | {cookies, CookieMode} -%% | {ipv6, Ipv6Mode} -%% Proxy - {Host, Port} -%% NoProxy - [Domain | HostName | IPAddress] -%% MaxSessions, MaxPipeline, PipelineTimeout = integer() -%% CookieMode - enabled | disabled | verify -%% Ipv6Mode - enabled | disabled -%% Description: Informs the httpc_manager of the new settings. -%%------------------------------------------------------------------------- -set_options(Options) -> - ensure_started(no_scheme), - httpc_manager:set_options(Options). - -verify_cookies(SetCookieHeaders, Url) -> - {_, _, Host, Port, Path, _} = http_uri:parse(Url), - Cookies = http_cookie:cookies(SetCookieHeaders, Path, Host), - httpc_manager:store_cookies(Cookies, {Host, Port}), - ok. - -cookie_header(Url) -> - httpc_manager:cookies(Url). - -%%%======================================================================== -%%% Internal functions -%%%======================================================================== -handle_request(Method, Url, {{Scheme, UserInfo, Host, Port, Path, Query}, - Headers, ContentType, Body}, HTTPOptions, Options) -> - HTTPRecordOptions = http_options(HTTPOptions, #http_options{}), - - Sync = http_util:key1search(Options, sync, true), - NewHeaders = lists:map(fun({Key, Val}) -> - {http_util:to_lower(Key), Val} end, - Headers), - Stream = http_util:key1search(Options, stream, none), - - case {Sync, Stream} of - {true, self} -> - {error, streaming_error}; - _ -> - RecordHeaders = header_record(NewHeaders, #http_request_h{}, Host), - Request = #request{from = self(), - scheme = Scheme, address = {Host,Port}, - path = Path, pquery = Query, method = Method, - headers = RecordHeaders, - content = {ContentType,Body}, - settings = HTTPRecordOptions, - abs_uri = Url, userinfo = UserInfo, - stream = Stream, - headers_as_is = - headers_as_is(Headers, Options)}, - - ensure_started(Scheme), - - case httpc_manager:request(Request) of - {ok, RequestId} -> - handle_answer(RequestId, Sync, Options); - {error, Reason} -> - {error, Reason} - end - end. - -handle_answer(RequestId, false, _) -> - {ok, RequestId}; -handle_answer(RequestId, true, Options) -> - receive - {http, {RequestId, saved_to_file}} -> - {ok, saved_to_file}; - {http, {RequestId, Result = {_,_,_}}} -> - return_answer(Options, Result); - {http, {RequestId, {error, Reason}}} -> - {error, Reason} - end. - -return_answer(Options, {StatusLine, Headers, BinBody}) -> - Body = - case http_util:key1search(Options, body_format, string) of - string -> - binary_to_list(BinBody); - _ -> - BinBody - end, - case http_util:key1search(Options, full_result, true) of - true -> - {ok, {StatusLine, Headers, Body}}; - false -> - {_, Status, _} = StatusLine, - {ok, {Status, Body}} - end. - - -%% This options is a workaround for http servers that do not follow the -%% http standard and have case sensative header parsing. Should only be -%% used if there is no other way to communicate with the server or for -%% testing purpose. -headers_as_is(Headers, Options) -> - case http_util:key1search(Options, headers_as_is, false) of - false -> - []; - true -> - Headers - end. - -http_options([], Acc) -> - Acc; -http_options([{timeout, Val} | Settings], Acc) - when is_integer(Val), Val >= 0-> - http_options(Settings, Acc#http_options{timeout = Val}); -http_options([{timeout, infinity} | Settings], Acc) -> - http_options(Settings, Acc#http_options{timeout = infinity}); -http_options([{autoredirect, Val} | Settings], Acc) - when Val == true; Val == false -> - http_options(Settings, Acc#http_options{autoredirect = Val}); -http_options([{ssl, Val} | Settings], Acc) -> - http_options(Settings, Acc#http_options{ssl = Val}); -http_options([{relaxed, Val} | Settings], Acc) - when Val == true; Val == false -> - http_options(Settings, Acc#http_options{relaxed = Val}); -http_options([{proxy_auth, Val = {User, Passwd}} | Settings], Acc) - when is_list(User), - is_list(Passwd) -> - http_options(Settings, Acc#http_options{proxy_auth = Val}); -http_options([Option | Settings], Acc) -> - error_logger:info_report("Invalid option ignored ~p~n", [Option]), - http_options(Settings, Acc). - -header_record([], RequestHeaders, Host) -> - validate_headers(RequestHeaders, Host); -header_record([{"cache-control", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{'cache-control' = Val}, - Host); -header_record([{"connection", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{connection = Val}, Host); -header_record([{"date", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{date = Val}, Host); -header_record([{"pragma", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{pragma = Val}, Host); -header_record([{"trailer", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{trailer = Val}, Host); -header_record([{"transfer-encoding", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, - RequestHeaders#http_request_h{'transfer-encoding' = Val}, - Host); -header_record([{"upgrade", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{upgrade = Val}, Host); -header_record([{"via", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{via = Val}, Host); -header_record([{"warning", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{warning = Val}, Host); -header_record([{"accept", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{accept = Val}, Host); -header_record([{"accept-charset", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{'accept-charset' = Val}, - Host); -header_record([{"accept-encoding", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{'accept-encoding' = Val}, - Host); -header_record([{"accept-language", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{'accept-language' = Val}, - Host); -header_record([{"authorization", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{authorization = Val}, - Host); -header_record([{"expect", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{expect = Val}, Host); -header_record([{"from", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{from = Val}, Host); -header_record([{"host", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{host = Val}, Host); -header_record([{"if-match", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{'if-match' = Val}, - Host); -header_record([{"if-modified-since", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, - RequestHeaders#http_request_h{'if-modified-since' = Val}, - Host); -header_record([{"if-none-match", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{'if-none-match' = Val}, - Host); -header_record([{"if-range", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{'if-range' = Val}, - Host); - -header_record([{"if-unmodified-since", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{'if-unmodified-since' - = Val}, Host); -header_record([{"max-forwards", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{'max-forwards' = Val}, - Host); -header_record([{"proxy-authorization", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{'proxy-authorization' - = Val}, Host); -header_record([{"range", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{range = Val}, Host); -header_record([{"referer", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{referer = Val}, Host); -header_record([{"te", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{te = Val}, Host); -header_record([{"user-agent", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{'user-agent' = Val}, - Host); -header_record([{"allow", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{allow = Val}, Host); -header_record([{"content-encoding", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, - RequestHeaders#http_request_h{'content-encoding' = Val}, - Host); -header_record([{"content-language", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, - RequestHeaders#http_request_h{'content-language' = Val}, - Host); -header_record([{"content-length", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{'content-length' = Val}, - Host); -header_record([{"content-location", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, - RequestHeaders#http_request_h{'content-location' = Val}, - Host); -header_record([{"content-md5", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{'content-md5' = Val}, - Host); -header_record([{"content-range", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{'content-range' = Val}, - Host); -header_record([{"content-type", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{'content-type' = Val}, - Host); -header_record([{"expires", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{expires = Val}, Host); -header_record([{"last-modified", Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{'last-modified' = Val}, - Host); -header_record([{Key, Val} | Rest], RequestHeaders, Host) -> - header_record(Rest, RequestHeaders#http_request_h{ - other = [{Key, Val} | - RequestHeaders#http_request_h.other]}, - Host). - -validate_headers(RequestHeaders = #http_request_h{te = undefined}, Host) -> - validate_headers(RequestHeaders#http_request_h{te = ""}, Host); -validate_headers(RequestHeaders = #http_request_h{host = undefined}, Host) -> - validate_headers(RequestHeaders#http_request_h{host = Host}, Host); -validate_headers(RequestHeaders, _) -> - RequestHeaders. - -ensure_started(Scheme) -> - %% Start of the inets application should really be handled by the - %% application using inets. - case application:start(couch_inets) of - {error,{already_started,couch_inets}} -> - ok; - {error, {{already_started,_}, % Started as an included application - {inets_app, start, _}}} -> - ok; - ok -> - error_logger:info_report("The inets application was not started." - " Has now been started as a temporary" - " application.") - end, - - case Scheme of - https -> - %% Start of the ssl application should really be handled by the - %% application using inets. - case application:start(ssl) of - {error,{already_started,ssl}} -> - ok; - %% Started as an included application - {error, {{already_started,_}, - {ssl_app, start, _}}} -> - ok; - ok -> - error_logger:info_report("The ssl application was not " - "started. Has now been started " - "as a temporary application.") - end; - _ -> - ok - end. diff --git a/src/couch_inets/http_base_64.erl b/src/couch_inets/http_base_64.erl deleted file mode 100644 index 00cd966b..00000000 --- a/src/couch_inets/http_base_64.erl +++ /dev/null @@ -1,126 +0,0 @@ -%% ``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$ -%% -%% Description: Implements base 64 encode and decode, see RFC2045. --module(http_base_64). - --export([encode/1, decode/1]). - --deprecated({'_', '_', next_major_release}). - -%%%========================================================================= -%%% API -%%%========================================================================= - -%%------------------------------------------------------------------------- -%% encode(ASCII) -> Base64 -%% ASCII - string() -%% Base64 - string() -%% -%% Description: Encodes a plain ASCII string into base64. -%%------------------------------------------------------------------------- -encode(ASCII) when is_list(ASCII) -> - encode_base64_list(ASCII). - - -%%------------------------------------------------------------------------- -%% decode(Base64) -> ASCII -%% Base64 - string() -%% ASCII - string() -%% -%% Description: Decodes an base64 encoded string to plain ASCII. -%%------------------------------------------------------------------------- -decode(Base64) when is_list(Base64) -> - decode_base64_list(sixtets(Base64), []). - -%%%======================================================================== -%%% Internal functions -%%%======================================================================== - -%% Base-64 encoding: take 6 bits at a time from the head of the binary -%% and emit it as 8 bit characters. -encode_base64_list([]) -> - []; -encode_base64_list([A]) -> - [int_to_b64(A bsr 2), int_to_b64((A band 3) bsl 4), $=, $=]; -encode_base64_list([A,B]) -> - [int_to_b64(A bsr 2), int_to_b64(((A band 3) bsl 4) bor (B bsr 4)), - int_to_b64((B band 15) bsl 2), $=]; -encode_base64_list([A,B,C|Ls]) -> - encode_base64_list_do(A,B,C, Ls). - -encode_base64_list_do(A,B,C, Rest) -> - BB = (A bsl 16) bor (B bsl 8) bor C, - [int_to_b64(BB bsr 18), int_to_b64((BB bsr 12) band 63), - int_to_b64((BB bsr 6) band 63), int_to_b64(BB band 63) | - encode_base64_list(Rest)]. - -int_to_b64(X) when X >= 0, X =< 25 -> X + $A; -int_to_b64(X) when X >= 26, X =< 51 -> X - 26 + $a; -int_to_b64(X) when X >= 52, X =< 61 -> X - 52 + $0; -int_to_b64(62) -> $+; -int_to_b64(63) -> $/. - -%% This version works by consuming groups of 4 input characters to create -%% a group of 3 output characters, with the three special-cases for -%% end-of-input first: - -decode_base64_list({[],[]}, Acc) -> - lists:reverse(Acc); -decode_base64_list({[Sixtet1,Sixtet2,pad,pad], []}, Acc) -> - Bits2x6 = (Sixtet1 bsl 18) bor (Sixtet2 bsl 12), - Octet1 = Bits2x6 bsr 16, - lists:reverse([Octet1 | Acc]); -decode_base64_list({[Sixtet1,Sixtet2,Sixtet3,pad], []}, Acc) -> - Bits3x6 = (Sixtet1 bsl 18) bor (Sixtet2 bsl 12) bor (Sixtet3 bsl 6), - Octet1 = Bits3x6 bsr 16, - Octet2 = (Bits3x6 bsr 8) band 16#ff, - lists:reverse([Octet2, Octet1 | Acc]); -decode_base64_list({[Sixtet1,Sixtet2,Sixtet3,Sixtet4],Rest}, Acc) when - Sixtet1 =/= pad, - Sixtet2 =/= pad, - Sixtet3 =/= pad, - Sixtet4 =/= pad -> - Bits4x6 = - (Sixtet1 bsl 18) bor (Sixtet2 bsl 12) bor (Sixtet3 bsl 6) bor Sixtet4, - Octet1 = Bits4x6 bsr 16, - Octet2 = (Bits4x6 bsr 8) band 16#ff, - Octet3 = Bits4x6 band 16#ff, - decode_base64_list(sixtets(Rest), [Octet3, Octet2, Octet1 | Acc]). - -b64_to_int(X) when X >= $A, X =< $Z -> X - $A; -b64_to_int(X) when X >= $a, X =< $z -> X - $a + 26; -b64_to_int(X) when X >= $0, X =< $9 -> X - $0 + 52; -b64_to_int($+) -> 62; -b64_to_int($/) -> 63; -b64_to_int($=) -> pad; % Padding will be removed by decode_base64_list/2 -b64_to_int(_) -> ignore. % Not in base 64 should be ignored - -sixtets(Str) -> - sixtets(Str, []). - -sixtets([], Sixtets) -> - {lists:reverse(Sixtets), []}; -sixtets(Rest, Sixtets) when length(Sixtets) == 4 -> - {lists:reverse(Sixtets), Rest}; -sixtets([Base64 | Tail], Sixtets) when length(Sixtets) < 4 -> - case b64_to_int(Base64) of - ignore -> - sixtets(Tail, Sixtets); - Int -> - sixtets(Tail, [Int | Sixtets]) - end. diff --git a/src/couch_inets/http_chunk.erl b/src/couch_inets/http_chunk.erl deleted file mode 100644 index 462cfcc5..00000000 --- a/src/couch_inets/http_chunk.erl +++ /dev/null @@ -1,289 +0,0 @@ -%% ``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$ -%% Description: Implements chunked transfer encoding see RFC2616 section -%% 3.6.1 --module(http_chunk). - --include("http_internal.hrl"). - -%% API --export([decode/3, decode/4, encode/1, encode_last/0, handle_headers/2]). -%% Callback API - used for example if the chunkedbody is received a -%% little at a time on a socket. --export([decode_size/1, ignore_extensions/1, decode_data/1, decode_trailer/1]). - -%%%========================================================================= -%%% API -%%%========================================================================= -%%------------------------------------------------------------------------- -%% decode(ChunkedBody, MaxBodySize, MaxHeaderSize, <Stream>) -> -%% {ok, {Headers, Body}} | {Module, Function, Args} -%% -%% Headers = ["Header:Value"] -%% ChunkedBody = binary() -%% MaxBodySize = integer() -%% MaxHeaderSize = integer() -%% Stream = {Code, Request} - if Request#request.stream =/= none -%% and Code == 200 the side effect of sending each decode chunk to the -%% client/file before the whole body is received will take place. -%% -%% Note: decode/4 should only be used from httpc_handler module. -%% Otherwhise use the side effect free decode/3. -%% -%% Description: Decodes a body encoded by the chunked transfer -%% encoding. If the ChunkedBody is not compleate it returns {Module, -%% Function, Args} so that decoding can be continued when more of the -%% data has been received by calling Module:Function([NewData | Args]). -%% -%% Note: In the case of pipelining a call to decode might contain data -%% that belongs to the next request/response and will be returned as -%% part of the body, hence functions calling http_chunk:decode must -%% look at the returned content-length header to make sure that they -%% split the actual body and data that possible should be passed along to -%% the next pass in the loop. -%%------------------------------------------------------------------------- -decode(ChunkedBody, MaxBodySize, MaxHeaderSize) -> - decode(ChunkedBody, MaxBodySize, MaxHeaderSize, false). - -decode(ChunkedBody, MaxBodySize, MaxHeaderSize, Stream) -> - %% Note decode_size will call decode_data. - decode_size([ChunkedBody, <<>>, [], - {MaxBodySize, <<>>, 0, MaxHeaderSize, Stream}]). - -%%------------------------------------------------------------------------- -%% encode(Chunk) -> EncodedChunk -%% -%% Chunked = binary() -%% EncodedChunk = binary() -%% -%% Description: Encodes a body part with the chunked transfer encoding. -%% Chunks are returned as lists or binaries depending on the -%% input format. When sending the data on the both formats -%% are accepted. -%%------------------------------------------------------------------------- -encode(Chunk) when is_binary(Chunk)-> - HEXSize = list_to_binary(http_util:integer_to_hexlist(size(Chunk))), - <<HEXSize/binary, ?CR, ?LF, Chunk/binary, ?CR, ?LF>>; - -encode(Chunk) when is_list(Chunk)-> - HEXSize = http_util:integer_to_hexlist(length(Chunk)), - [HEXSize, ?CR, ?LF, Chunk, ?CR, ?LF]. - -encode_last() -> - <<$0, ?CR, ?LF, ?CR, ?LF >>. - -%%------------------------------------------------------------------------- -%% handle_headers(HeaderRecord, ChunkedHeaders) -> NewHeaderRecord -%% -%% HeaderRecord = NewHeaderRecord = #http_request_h{} | #http_response_h{} -%% ChunkedHeaders = ["Header:Value"] as returnde by http_chunk:decode/3 -%% -%% Description: Removes chunked from the header as we now have decode -%% the body and adds a content-length header and any other headers -%% found in the chunked trail. -%%------------------------------------------------------------------------- -handle_headers(RequestHeaderRecord = #http_request_h{}, ChunkedHeaders) -> - NewHeaders = http_request:headers(ChunkedHeaders, RequestHeaderRecord), - TransferEncoding = - case NewHeaders#http_request_h.'transfer-encoding' -- "chunked" of - "" -> - undefined; - Other -> - Other - end, - NewHeaders#http_request_h{'transfer-encoding' = TransferEncoding}; - -handle_headers(ResponseHeaderRecord = #http_response_h{}, ChunkedHeaders) -> - NewHeaders = http_response:headers(ChunkedHeaders, ResponseHeaderRecord), - TransferEncoding = - case NewHeaders#http_response_h.'transfer-encoding' -- "chunked" of - "" -> - undefined; - Other -> - Other - end, - NewHeaders#http_response_h{'transfer-encoding' = TransferEncoding}. - -%% Functions that may be returned during the decoding process -%% if the input data is incompleate. -decode_size([Bin, Rest, HexList, Info]) -> - decode_size(<<Rest/binary, Bin/binary>>, HexList, Info). - -ignore_extensions([Bin, Rest, NextFunction]) -> - ignore_extensions(<<Rest/binary, Bin/binary>>, NextFunction). - -decode_data([Bin, ChunkSize, TotalChunk, Info]) -> - decode_data(ChunkSize, <<TotalChunk/binary, Bin/binary>>, Info). - -decode_trailer([Bin, Rest, Header, Headers, MaxHeaderSize, Body, - BodyLength]) -> - decode_trailer(<<Rest/binary, Bin/binary>>, - Header, Headers, MaxHeaderSize, Body, BodyLength). - -%%%======================================================================== -%%% Internal functions -%%%======================================================================== -decode_size(<<>>, HexList, Info) -> - {?MODULE, decode_size, [<<>>, HexList, Info]}; -decode_size(Data = <<?CR, ?LF, ChunkRest/binary>>, HexList, - {MaxBodySize, Body, - AccLength, - MaxHeaderSize, Stream}) -> - ChunkSize = http_util:hexlist_to_integer(lists:reverse(HexList)), - case ChunkSize of - 0 -> % Last chunk, there was no data - ignore_extensions(Data, {?MODULE, decode_trailer, - [<<>>, [],[], MaxHeaderSize, - Body, - integer_to_list(AccLength)]}); - _ -> - %% Note decode_data may call decode_size again if there - %% is more than one chunk, hence here is where the last parameter - %% to this function comes in. - decode_data(ChunkSize, ChunkRest, {MaxBodySize, Body, - ChunkSize + AccLength , - MaxHeaderSize, Stream}) - end; -decode_size(<<";", Rest/binary>>, HexList, Info) -> - %% Note ignore_extensions will call decode_size/1 again when - %% it ignored all extensions. - ignore_extensions(Rest, {?MODULE, decode_size, [<<>>, HexList, Info]}); -decode_size(<<?CR>> = Data, HexList, Info) -> - {?MODULE, decode_size, [Data, HexList, Info]}; -decode_size(<<Octet, Rest/binary>>, HexList, Info) -> - decode_size(Rest, [Octet | HexList], Info). - -%% "All applications MUST ignore chunk-extension extensions they -%% do not understand.", see RFC 2616 Section 3.6.1 We don't -%% understand any extension... -ignore_extensions(<<>>, NextFunction) -> - {?MODULE, ignore_extensions, [<<>>, NextFunction]}; -ignore_extensions(Data = <<?CR, ?LF, _ChunkRest/binary>>, - {Module, Function, Args}) -> - Module:Function([Data | Args]); -ignore_extensions(<<?CR>> = Data, NextFunction) -> - {?MODULE, ignore_extensions, [Data, NextFunction]}; -ignore_extensions(<<_Octet, Rest/binary>>, NextFunction) -> - ignore_extensions(Rest, NextFunction). - -decode_data(ChunkSize, TotalChunk, - Info = {MaxBodySize, BodySoFar, AccLength, MaxHeaderSize, Stream}) - when ChunkSize =< size(TotalChunk) -> - case TotalChunk of - %% Potential last chunk - <<_:ChunkSize/binary, ?CR, ?LF, "0">> -> - {?MODULE, decode_data, [ChunkSize, TotalChunk, Info]}; - <<_:ChunkSize/binary, ?CR, ?LF, "0", ?CR>> -> - {?MODULE, decode_data, [ChunkSize, TotalChunk, Info]}; - <<_:ChunkSize/binary, ?CR, ?LF>> -> - {?MODULE, decode_data, [ChunkSize, TotalChunk, Info]}; - %% Last chunk - <<Data:ChunkSize/binary, ?CR, ?LF, "0", ";">> -> - %% Note ignore_extensions will call decode_trailer/1 - %% once it ignored all extensions. - {NewBody, _} = - stream(<<BodySoFar/binary, Data/binary>>, Stream), - {?MODULE, ignore_extensions, - [<<>>, - {?MODULE, decode_trailer, [<<>>, [],[], MaxHeaderSize, - NewBody, - integer_to_list(AccLength)]}]}; - <<Data:ChunkSize/binary, ?CR, ?LF, "0", ";", Rest/binary>> -> - %% Note ignore_extensions will call decode_trailer/1 - %% once it ignored all extensions. - {NewBody, _} = stream(<<BodySoFar/binary, Data/binary>>, Stream), - ignore_extensions(Rest, {?MODULE, decode_trailer, - [<<>>, [],[], MaxHeaderSize, - NewBody, - integer_to_list(AccLength)]}); - <<Data:ChunkSize/binary, ?CR, ?LF, "0", ?CR, ?LF>> -> - {NewBody, _} = stream(<<BodySoFar/binary, Data/binary>>, Stream), - {?MODULE, decode_trailer, [<<?CR, ?LF>>, [],[], MaxHeaderSize, - NewBody, - integer_to_list(AccLength)]}; - <<Data:ChunkSize/binary, ?CR, ?LF, "0", ?CR, ?LF, Rest/binary>> -> - {NewBody,_}= stream(<<BodySoFar/binary, Data/binary>>, Stream), - decode_trailer(<<?CR, ?LF, Rest/binary>>, [],[], MaxHeaderSize, - NewBody, - integer_to_list(AccLength)); - %% There are more chunks, so here we go agin... - <<Data:ChunkSize/binary, ?CR, ?LF, Rest/binary>> - when (AccLength < MaxBodySize) or (MaxBodySize == nolimit) -> - {NewBody, NewStream} = - stream(<<BodySoFar/binary, Data/binary>>, Stream), - decode_size(Rest, [], - {MaxBodySize, NewBody, - AccLength, MaxHeaderSize, NewStream}); - <<_:ChunkSize/binary, ?CR, ?LF, _/binary>> -> - throw({error, body_too_big}); - _ -> - {?MODULE, decode_data, [ChunkSize, TotalChunk, Info]} - end; -decode_data(ChunkSize, TotalChunk, Info) -> - {?MODULE, decode_data, [ChunkSize, TotalChunk, Info]}. - -decode_trailer(<<>>, Header, Headers, MaxHeaderSize, Body, BodyLength) -> - {?MODULE, decode_trailer, [<<>>, Header, Headers, MaxHeaderSize, Body, - BodyLength]}; - -%% Note: If Bin is not empty it is part of a pipelined request/response. -decode_trailer(<<?CR,?LF,?CR,?LF, Bin/binary>>, [], [], _, Body, BodyLength) -> - {ok, {["content-length:" ++ BodyLength], <<Body/binary, Bin/binary>>}}; -decode_trailer(<<?CR,?LF,?CR,?LF, Bin/binary>>, - Header, Headers, MaxHeaderSize, Body, BodyLength) -> - NewHeaders = case Header of - [] -> - Headers; - _ -> - [lists:reverse(Header) | Headers] - end, - Length = length(NewHeaders), - case Length > MaxHeaderSize of - true -> - throw({error, {header_too_long, MaxHeaderSize, - MaxHeaderSize-Length}}); - false -> - {ok, {["content-length:" ++ BodyLength | NewHeaders], - <<Body/binary, Bin/binary>>}} - end; -decode_trailer(<<?CR,?LF,?CR>> = Data, Header, Headers, MaxHeaderSize, - Body, BodyLength) -> - {?MODULE, decode_trailer, [Data, Header, Headers, MaxHeaderSize, Body, - BodyLength]}; -decode_trailer(<<?CR,?LF>> = Data, Header, Headers, MaxHeaderSize, - Body, BodyLength) -> - {?MODULE, decode_trailer, [Data, Header, Headers, MaxHeaderSize, Body, - BodyLength]}; -decode_trailer(<<?CR>> = Data, Header, Headers, MaxHeaderSize, - Body, BodyLength) -> - {?MODULE, decode_trailer, [Data, Header, Headers, MaxHeaderSize, Body, - BodyLength]}; -decode_trailer(<<?CR, ?LF, Rest/binary>>, Header, Headers, - MaxHeaderSize, Body, BodyLength) -> - decode_trailer(Rest, [], [lists:reverse(Header) | Headers], - MaxHeaderSize, Body, BodyLength); - -decode_trailer(<<Octet, Rest/binary>>, Header, Headers, MaxHeaderSize, Body, - BodyLength) -> - decode_trailer(Rest, [Octet | Header], Headers, MaxHeaderSize, - Body, BodyLength). - -stream(BodyPart, false) -> - {BodyPart, false}; -stream(BodyPart, {Code, Request}) -> - {NewBody, NewRequest} = httpc_handler:stream(BodyPart, Request, Code), - {NewBody, {Code, NewRequest}}. diff --git a/src/couch_inets/http_cookie.erl b/src/couch_inets/http_cookie.erl deleted file mode 100644 index a8e68651..00000000 --- a/src/couch_inets/http_cookie.erl +++ /dev/null @@ -1,389 +0,0 @@ -%% ``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$ -%% Description: Cookie handling according to RFC 2109 - --module(http_cookie). - --include("httpc_internal.hrl"). - --export([header/4, cookies/3, open_cookie_db/1, close_cookie_db/1, insert/2]). - -%%%========================================================================= -%%% API -%%%========================================================================= -header(Scheme, {Host, _}, Path, CookieDb) -> - case lookup_cookies(Host, Path, CookieDb) of - [] -> - {"cookie", ""}; - Cookies -> - {"cookie", cookies_to_string(Scheme, Cookies)} - end. - -cookies(Headers, RequestPath, RequestHost) -> - Cookies = parse_set_cookies(Headers, {RequestPath, RequestHost}), - accept_cookies(Cookies, RequestPath, RequestHost). - -open_cookie_db({{_, only_session_cookies}, SessionDbName}) -> - EtsDb = ets:new(SessionDbName, [protected, bag, - {keypos, #http_cookie.domain}]), - {undefined, EtsDb}; - -open_cookie_db({{DbName, Dbdir}, SessionDbName}) -> - File = filename:join(Dbdir, atom_to_list(DbName)), - {ok, DetsDb} = dets:open_file(DbName, [{keypos, #http_cookie.domain}, - {type, bag}, - {file, File}, - {ram_file, true}]), - EtsDb = ets:new(SessionDbName, [protected, bag, - {keypos, #http_cookie.domain}]), - {DetsDb, EtsDb}. - -close_cookie_db({undefined, EtsDb}) -> - ets:delete(EtsDb); - -close_cookie_db({DetsDb, EtsDb}) -> - dets:close(DetsDb), - ets:delete(EtsDb). - -%% If no persistent cookie database is defined we -%% treat all cookies as if they where session cookies. -insert(Cookie = #http_cookie{max_age = Int}, - Dbs = {undefined, _}) when is_integer(Int) -> - insert(Cookie#http_cookie{max_age = session}, Dbs); - -insert(Cookie = #http_cookie{domain = Key, name = Name, - path = Path, max_age = session}, - Db = {_, CookieDb}) -> - case ets:match_object(CookieDb, #http_cookie{domain = Key, - name = Name, - path = Path, - _ = '_'}) of - [] -> - ets:insert(CookieDb, Cookie); - [NewCookie] -> - delete(NewCookie, Db), - ets:insert(CookieDb, Cookie) - end, - ok; -insert(#http_cookie{domain = Key, name = Name, - path = Path, max_age = 0}, - Db = {CookieDb, _}) -> - case dets:match_object(CookieDb, #http_cookie{domain = Key, - name = Name, - path = Path, - _ = '_'}) of - [] -> - ok; - [NewCookie] -> - delete(NewCookie, Db) - end, - ok; -insert(Cookie = #http_cookie{domain = Key, name = Name, path = Path}, - Db = {CookieDb, _}) -> - case dets:match_object(CookieDb, #http_cookie{domain = Key, - name = Name, - path = Path, - _ = '_'}) of - [] -> - dets:insert(CookieDb, Cookie); - [NewCookie] -> - delete(NewCookie, Db), - dets:insert(CookieDb, Cookie) - end, - ok. - -%%%======================================================================== -%%% Internal functions -%%%======================================================================== -lookup_cookies(Key, {undefined, Ets}) -> - ets:match_object(Ets, #http_cookie{domain = Key, - _ = '_'}); -lookup_cookies(Key, {Dets,Ets}) -> - SessionCookies = ets:match_object(Ets, #http_cookie{domain = Key, - _ = '_'}), - Cookies = dets:match_object(Dets, #http_cookie{domain = Key, - _ = '_'}), - Cookies ++ SessionCookies. - -delete(Cookie = #http_cookie{max_age = session}, {_, CookieDb}) -> - ets:delete_object(CookieDb, Cookie); -delete(Cookie, {CookieDb, _}) -> - dets:delete_object(CookieDb, Cookie). - -lookup_cookies(Host, Path, Db) -> - Cookies = - case http_util:is_hostname(Host) of - true -> - HostCookies = lookup_cookies(Host, Db), - [_| DomainParts] = string:tokens(Host, "."), - lookup_domain_cookies(DomainParts, Db, HostCookies); - false -> % IP-adress - lookup_cookies(Host, Db) - end, - ValidCookies = valid_cookies(Cookies, [], Db), - lists:filter(fun(Cookie) -> - lists:prefix(Cookie#http_cookie.path, Path) - end, ValidCookies). - -%% For instance if Host=localhost -lookup_domain_cookies([], _, AccCookies) -> - lists:flatten(AccCookies); -%% Top domains can not have cookies -lookup_domain_cookies([_], _, AccCookies) -> - lists:flatten(AccCookies); -lookup_domain_cookies([Next | DomainParts], CookieDb, AccCookies) -> - Domain = merge_domain_parts(DomainParts, [Next ++ "."]), - lookup_domain_cookies(DomainParts, CookieDb, - [lookup_cookies(Domain, CookieDb) - | AccCookies]). - -merge_domain_parts([Part], Merged) -> - lists:flatten(["." | lists:reverse([Part | Merged])]); -merge_domain_parts([Part| Rest], Merged) -> - merge_domain_parts(Rest, [".", Part | Merged]). - -cookies_to_string(Scheme, Cookies = [Cookie | _]) -> - Version = "$Version=" ++ Cookie#http_cookie.version ++ "; ", - cookies_to_string(Scheme, path_sort(Cookies), [Version]). - -cookies_to_string(_, [], CookieStrs) -> - case length(CookieStrs) of - 1 -> - ""; - _ -> - lists:flatten(lists:reverse(CookieStrs)) - end; - -cookies_to_string(https, [Cookie = #http_cookie{secure = true}| Cookies], - CookieStrs) -> - Str = case Cookies of - [] -> - cookie_to_string(Cookie); - _ -> - cookie_to_string(Cookie) ++ "; " - end, - cookies_to_string(https, Cookies, [Str | CookieStrs]); - -cookies_to_string(Scheme, [#http_cookie{secure = true}| Cookies], - CookieStrs) -> - cookies_to_string(Scheme, Cookies, CookieStrs); - -cookies_to_string(Scheme, [Cookie | Cookies], CookieStrs) -> - Str = case Cookies of - [] -> - cookie_to_string(Cookie); - _ -> - cookie_to_string(Cookie) ++ "; " - end, - cookies_to_string(Scheme, Cookies, [Str | CookieStrs]). - -cookie_to_string(Cookie = #http_cookie{name = Name, value = Value}) -> - Str = Name ++ "=" ++ Value, - add_domain(add_path(Str, Cookie), Cookie). - -add_path(Str, #http_cookie{path_default = true}) -> - Str; -add_path(Str, #http_cookie{path = Path}) -> - Str ++ "; $Path=" ++ Path. - -add_domain(Str, #http_cookie{domain_default = true}) -> - Str; -add_domain(Str, #http_cookie{domain = Domain}) -> - Str ++ "; $Domain=" ++ Domain. - -parse_set_cookies(OtherHeaders, DefaultPathDomain) -> - SetCookieHeaders = lists:foldl(fun({"set-cookie", Value}, Acc) -> - [string:tokens(Value, ",")| Acc]; - (_, Acc) -> - Acc - end, [], OtherHeaders), - - lists:flatten(lists:map(fun(CookieHeader) -> - NewHeader = - fix_netscape_cookie(CookieHeader, - []), - parse_set_cookie(NewHeader, [], - DefaultPathDomain) end, - SetCookieHeaders)). - -parse_set_cookie([], AccCookies, _) -> - AccCookies; -parse_set_cookie([CookieHeader | CookieHeaders], AccCookies, - Defaults = {DefaultPath, DefaultDomain}) -> - [CookieStr | Attributes] = case string:tokens(CookieHeader, ";") of - [CStr] -> - [CStr, ""]; - [CStr | Attr] -> - [CStr, Attr] - end, - Pos = string:chr(CookieStr, $=), - Name = string:substr(CookieStr, 1, Pos - 1), - Value = string:substr(CookieStr, Pos + 1), - Cookie = #http_cookie{name = string:strip(Name), - value = string:strip(Value)}, - NewAttributes = parse_set_cookie_attributes(Attributes), - TmpCookie = cookie_attributes(NewAttributes, Cookie), - %% Add runtime defult values if necessary - NewCookie = domain_default(path_default(TmpCookie, DefaultPath), - DefaultDomain), - parse_set_cookie(CookieHeaders, [NewCookie | AccCookies], Defaults). - -parse_set_cookie_attributes([]) -> - []; -parse_set_cookie_attributes([Attributes]) -> - lists:map(fun(Attr) -> - [AttrName, AttrValue] = - case string:tokens(Attr, "=") of - %% All attributes have the form - %% Name=Value except "secure"! - [Name] -> - [Name, ""]; - [Name, Value] -> - [Name, Value]; - %% Anything not expected will be - %% disregarded - _ -> - ["Dummy",""] - end, - {http_util:to_lower(string:strip(AttrName)), - string:strip(AttrValue)} - end, Attributes). - -cookie_attributes([], Cookie) -> - Cookie; -cookie_attributes([{"comment", Value}| Attributes], Cookie) -> - cookie_attributes(Attributes, - Cookie#http_cookie{comment = Value}); -cookie_attributes([{"domain", Value}| Attributes], Cookie) -> - cookie_attributes(Attributes, - Cookie#http_cookie{domain = Value}); -cookie_attributes([{"max-age", Value}| Attributes], Cookie) -> - ExpireTime = cookie_expires(list_to_integer(Value)), - cookie_attributes(Attributes, - Cookie#http_cookie{max_age = ExpireTime}); -%% Backwards compatibility with netscape cookies -cookie_attributes([{"expires", Value}| Attributes], Cookie) -> - Time = http_util:convert_netscapecookie_date(Value), - ExpireTime = calendar:datetime_to_gregorian_seconds(Time), - cookie_attributes(Attributes, - Cookie#http_cookie{max_age = ExpireTime}); -cookie_attributes([{"path", Value}| Attributes], Cookie) -> - cookie_attributes(Attributes, - Cookie#http_cookie{path = Value}); -cookie_attributes([{"secure", _}| Attributes], Cookie) -> - cookie_attributes(Attributes, - Cookie#http_cookie{secure = true}); -cookie_attributes([{"version", Value}| Attributes], Cookie) -> - cookie_attributes(Attributes, - Cookie#http_cookie{version = Value}); -%% Disregard unknown attributes. -cookie_attributes([_| Attributes], Cookie) -> - cookie_attributes(Attributes, Cookie). - -domain_default(Cookie = #http_cookie{domain = undefined}, - DefaultDomain) -> - Cookie#http_cookie{domain = DefaultDomain, domain_default = true}; -domain_default(Cookie, _) -> - Cookie. - -path_default(Cookie = #http_cookie{path = undefined}, - DefaultPath) -> - Cookie#http_cookie{path = skip_right_most_slash(DefaultPath), - path_default = true}; -path_default(Cookie, _) -> - Cookie. - -%% Note: if the path is only / that / will be keept -skip_right_most_slash("/") -> - "/"; -skip_right_most_slash(Str) -> - string:strip(Str, right, $/). - -accept_cookies(Cookies, RequestPath, RequestHost) -> - lists:filter(fun(Cookie) -> - accept_cookie(Cookie, RequestPath, RequestHost) - end, Cookies). - -accept_cookie(Cookie, RequestPath, RequestHost) -> - accept_path(Cookie, RequestPath) and accept_domain(Cookie, RequestHost). - -accept_path(#http_cookie{path = Path}, RequestPath) -> - lists:prefix(Path, RequestPath). - -accept_domain(#http_cookie{domain = RequestHost}, RequestHost) -> - true; - -accept_domain(#http_cookie{domain = Domain}, RequestHost) -> - HostCheck = case http_util:is_hostname(RequestHost) of - true -> - (lists:suffix(Domain, RequestHost) andalso - (not - lists:member($., - string:substr(RequestHost, 1, - (length(RequestHost) - - length(Domain)))))); - false -> - false - end, - HostCheck andalso (hd(Domain) == $.) - andalso (length(string:tokens(Domain, ".")) > 1). - -cookie_expires(0) -> - 0; -cookie_expires(DeltaSec) -> - NowSec = calendar:datetime_to_gregorian_seconds({date(), time()}), - NowSec + DeltaSec. - -is_cookie_expired(#http_cookie{max_age = session}) -> - false; -is_cookie_expired(#http_cookie{max_age = ExpireTime}) -> - NowSec = calendar:datetime_to_gregorian_seconds({date(), time()}), - ExpireTime - NowSec =< 0. - -valid_cookies([], Valid, _) -> - Valid; - -valid_cookies([Cookie | Cookies], Valid, Db) -> - case is_cookie_expired(Cookie) of - true -> - delete(Cookie, Db), - valid_cookies(Cookies, Valid, Db); - false -> - valid_cookies(Cookies, [Cookie | Valid], Db) - end. - -path_sort(Cookies)-> - lists:reverse(lists:keysort(#http_cookie.path, Cookies)). - - -%% Informally, the Set-Cookie response header comprises the token -%% Set-Cookie:, followed by a comma-separated list of one or more -%% cookies. Netscape cookies expires attribute may also have a -%% , in this case the header list will have been incorrectly split -%% in parse_set_cookies/2 this functions fixs that problem. -fix_netscape_cookie([Cookie1, Cookie2 | Rest], Acc) -> - case regexp:match(Cookie1, "expires=") of - {_, _, _} -> - fix_netscape_cookie(Rest, [Cookie1 ++ Cookie2 | Acc]); - nomatch -> - fix_netscape_cookie([Cookie2 |Rest], [Cookie1| Acc]) - end; -fix_netscape_cookie([Cookie | Rest], Acc) -> - fix_netscape_cookie(Rest, [Cookie | Acc]); - -fix_netscape_cookie([], Acc) -> - Acc. diff --git a/src/couch_inets/http_internal.hrl b/src/couch_inets/http_internal.hrl deleted file mode 100644 index 2dda55a2..00000000 --- a/src/couch_inets/http_internal.hrl +++ /dev/null @@ -1,105 +0,0 @@ -%% ``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$ -%% - --include("inets_internal.hrl"). - --define(HTTP_MAX_BODY_SIZE, nolimit). --define(HTTP_MAX_HEADER_SIZE, 10240). - -%%% Response headers --record(http_response_h,{ -%%% --- Standard "General" headers - 'cache-control', - connection, - date, - pragma, - trailer, - 'transfer-encoding', - upgrade, - via, - warning, -%%% --- Standard "Response" headers - 'accept-ranges', - age, - etag, - location, - 'proxy-authenticate', - 'retry-after', - server, - vary, - 'www-authenticate', -%%% --- Standard "Entity" headers - allow, - 'content-encoding', - 'content-language', - 'content-length' = "-1", - 'content-location', - 'content-md5', - 'content-range', - 'content-type', - expires, - 'last-modified', - other=[] % list() - Key/Value list with other headers - }). - - -%%% Request headers --record(http_request_h,{ -%%% --- 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, - from, - host, - 'if-match', - 'if-modified-since', - 'if-none-match', - 'if-range', - 'if-unmodified-since', - 'max-forwards', - 'proxy-authorization', - range, - referer, - te, - 'user-agent', -%%% --- 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 - }). diff --git a/src/couch_inets/http_request.erl b/src/couch_inets/http_request.erl deleted file mode 100644 index 138dc338..00000000 --- a/src/couch_inets/http_request.erl +++ /dev/null @@ -1,278 +0,0 @@ -%% ``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$ - --module(http_request). - --include("http_internal.hrl"). - --export([headers/2, http_headers/1, is_absolut_uri/1]). - -%%------------------------------------------------------------------------- -%% headers(HeaderList, #http_request_h{}) -> #http_request_h{} -%% HeaderList - ["HeaderField:Value"] -%% HeaderField - string() -%% Value - string() -%% -%% Description: Creates a http_request_h-record used internally to -%% handle http-headers. -%%------------------------------------------------------------------------- -headers([], Headers) -> - Headers; -headers([Header | Tail], Headers) -> - case lists:splitwith(fun($:) -> false; (_) -> true end, Header) of - {Key, [$: | Value]} -> - headers(Tail, headers(http_util:to_lower(string:strip(Key)), - string:strip(Value), Headers)); - {_, []} -> - error_logger:error_report("Ignored invalid HTTP-header: ~p~n", - [Header]), - headers(Tail, Headers) - end. - -%%------------------------------------------------------------------------- -%% headers(#http_request_h{}) -> HeaderList -%% HeaderList - ["HeaderField:Value"] -%% HeaderField - string() -%% Value - string() -%% -%% Description: Creates a HTTP header string. -%%------------------------------------------------------------------------- -http_headers(Headers = #http_request_h{other = Other}) -> - HeaderFields = record_info(fields, http_request_h) -- [other], - HeaderStr = lists:foldl(fun(Key, Acc) -> - case key_value_str(Key, Headers) of - undefined -> - Acc; - Str -> - [Str | Acc] - end - end, - [], HeaderFields), - - lists:flatten([HeaderStr | headers_other(Other, [])]). - -%%------------------------------------------------------------------------- -%% is_absolut_uri(URI) -> true | false -%% URI - string() -%% -%% Description: Checks if an URI is absolute or relative -%%------------------------------------------------------------------------- -is_absolut_uri("http://" ++ _) -> - true; -is_absolut_uri("https://" ++ _) -> - true; -is_absolut_uri(_) -> - false. - -%%%======================================================================== -%%% Internal functions -%%%======================================================================== - -%%% --- Request headers -headers("accept", Value, Headers) -> - Headers#http_request_h{accept = Value}; -headers("accept-charset", Value, Headers) -> - Headers#http_request_h{'accept-charset' = Value}; -headers("accept-encoding", Value, Headers) -> - Headers#http_request_h{'accept-encoding' = Value}; -headers("accept-language", Value, Headers) -> - Headers#http_request_h{'accept-language' = Value}; -headers("authorization", Value, Headers) -> - Headers#http_request_h{authorization = Value}; -headers("expect", Value, Headers) -> - Headers#http_request_h{expect = Value}; -headers("from", Value, Headers) -> - Headers#http_request_h{from = Value}; -headers("host", Value, Headers) -> - Headers#http_request_h{host = Value}; -headers("if-match", Value, Headers) -> - Headers#http_request_h{'if-match' = Value}; -headers("if-modified-since", Value, Headers) -> - Headers#http_request_h{'if-modified-since' = Value}; -headers("if-none-match", Value, Headers) -> - Headers#http_request_h{'if-none-match' = Value}; -headers("if-range", Value, Headers) -> - Headers#http_request_h{'if-range' = Value}; -headers("if-unmodified-since", Value, Headers) -> - Headers#http_request_h{'if-unmodified-since' = Value}; -headers("max-forwards", Value, Headers) -> - Headers#http_request_h{'max-forwards' = Value}; -headers("proxy-authorization", Value, Headers) -> - Headers#http_request_h{'proxy-authorization' = Value}; -headers("range", Value, Headers) -> - Headers#http_request_h{range = Value}; -headers("referer", Value, Headers) -> - Headers#http_request_h{referer = Value}; -headers("te", Value, Headers) -> - Headers#http_request_h{te = Value}; -headers("user-agent", Value, Headers) -> - Headers#http_request_h{'user-agent' = Value}; - -%% General-Headers -headers("cache-control", Value, Headers) -> - Headers#http_request_h{'cache-control' = Value}; -headers("connection", Value, Headers) -> - Headers#http_request_h{connection = Value}; -headers("date", Value, Headers) -> - Headers#http_request_h{date = Value}; -headers("pragma", Value, Headers) -> - Headers#http_request_h{pragma = Value}; -headers("trailer", Value, Headers) -> - Headers#http_request_h{trailer = Value}; -headers("transfer-encoding", Value, Headers) -> - Headers#http_request_h{'transfer-encoding' = Value}; -headers("upgrade", Value, Headers) -> - Headers#http_request_h{upgrade = Value}; -headers("via", Value, Headers) -> - Headers#http_request_h{via = Value}; -headers("warning", Value, Headers) -> - Headers#http_request_h{warning = Value}; - -%% Entity header -headers("allow", Value, Headers) -> - Headers#http_request_h{allow = Value}; -headers("content-encoding", Value, Headers) -> - Headers#http_request_h{'content-encoding' = Value}; -headers("content-language", Value, Headers) -> - Headers#http_request_h{'content-language' = Value}; -headers("content-length", Value, Headers) -> - Headers#http_request_h{'content-length' = Value}; -headers("content-location", Value, Headers) -> - Headers#http_request_h{'content-location' = Value}; -headers("content-md5", Value, Headers) -> - Headers#http_request_h{'content-md5' = Value}; -headers("content-range", Value, Headers) -> - Headers#http_request_h{'content-range' = Value}; -headers("content-type", Value, Headers) -> - Headers#http_request_h{'content-type' = Value}; -headers("expires", Value, Headers) -> - Headers#http_request_h{expires = Value}; -headers("last-modified", Value, Headers) -> - Headers#http_request_h{'last-modified' = Value}; -headers(Key, Value, Headers) -> - Headers#http_request_h{other= - [{Key, Value} | Headers#http_request_h.other]}. - -key_value_str(Key = 'cache-control', Headers) -> - key_value_str(atom_to_list(Key), Headers#http_request_h.'cache-control'); -key_value_str(Key = connection, Headers) -> - key_value_str(atom_to_list(Key), Headers#http_request_h.connection); -key_value_str(Key = date, Headers) -> - key_value_str(atom_to_list(Key), Headers#http_request_h.date); -key_value_str(Key = pragma, Headers) -> - key_value_str(atom_to_list(Key), Headers#http_request_h.pragma); -key_value_str(Key = trailer, Headers) -> - key_value_str(atom_to_list(Key), Headers#http_request_h.trailer); -key_value_str(Key = 'transfer-encoding', Headers) -> - key_value_str(atom_to_list(Key), - Headers#http_request_h.'transfer-encoding'); -key_value_str(Key = upgrade, Headers) -> - key_value_str(atom_to_list(Key), Headers#http_request_h.upgrade); -key_value_str(Key = via, Headers) -> - key_value_str(atom_to_list(Key), Headers#http_request_h.via); -key_value_str(Key = warning, Headers) -> - key_value_str(atom_to_list(Key), Headers#http_request_h.warning); -key_value_str(Key = accept, Headers) -> - key_value_str(atom_to_list(Key), Headers#http_request_h.accept); -key_value_str(Key = 'accept-charset', Headers) -> - key_value_str(atom_to_list(Key), Headers#http_request_h.'accept-charset'); -key_value_str(Key = 'accept-encoding', Headers) -> - key_value_str(atom_to_list(Key), Headers#http_request_h.'accept-encoding'); -key_value_str(Key = 'accept-language', Headers) -> - key_value_str(atom_to_list(Key), Headers#http_request_h.'accept-language'); -key_value_str(Key = authorization, Headers) -> - key_value_str(atom_to_list(Key), - Headers#http_request_h.authorization); -key_value_str(Key = expect, Headers) -> - key_value_str(atom_to_list(Key), Headers#http_request_h.expect); -key_value_str(Key = from, Headers) -> - key_value_str(atom_to_list(Key), Headers#http_request_h.from); -key_value_str(Key = host, Headers) -> - key_value_str(atom_to_list(Key), Headers#http_request_h.host); -key_value_str(Key = 'if-match', Headers) -> - key_value_str(atom_to_list(Key), - Headers#http_request_h.'if-match'); -key_value_str(Key = 'if-modified-since', Headers) -> - key_value_str(atom_to_list(Key), - Headers#http_request_h.'if-modified-since'); -key_value_str(Key = 'if-none-match', Headers) -> - key_value_str(atom_to_list(Key), - Headers#http_request_h.'if-none-match'); -key_value_str(Key = 'if-range', Headers) -> - key_value_str(atom_to_list(Key), - Headers#http_request_h.'if-range'); -key_value_str(Key = 'if-unmodified-since', Headers) -> - key_value_str(atom_to_list(Key), - Headers#http_request_h.'if-unmodified-since'); -key_value_str(Key = 'max-forwards', Headers) -> - key_value_str(atom_to_list(Key), - Headers#http_request_h.'max-forwards'); -key_value_str(Key = 'proxy-authorization', Headers) -> - key_value_str(atom_to_list(Key), - Headers#http_request_h.'proxy-authorization'); -key_value_str(Key = range, Headers) -> - key_value_str(atom_to_list(Key), - Headers#http_request_h.range); -key_value_str(Key = referer, Headers) -> - key_value_str(atom_to_list(Key), - Headers#http_request_h.referer); -key_value_str(Key = te, Headers) -> - key_value_str(atom_to_list(Key), - Headers#http_request_h.te); -key_value_str(Key = 'user-agent', Headers) -> - key_value_str(atom_to_list(Key), - Headers#http_request_h.'user-agent'); -key_value_str(Key = allow, Headers) -> - key_value_str(atom_to_list(Key), Headers#http_request_h.allow); -key_value_str(Key = 'content-encoding', Headers) -> - key_value_str(atom_to_list(Key), - Headers#http_request_h.'content-encoding'); -key_value_str(Key = 'content-language', Headers) -> - key_value_str(atom_to_list(Key), - Headers#http_request_h.'content-language'); -key_value_str(Key = 'content-length', Headers) -> - case Headers#http_request_h.'content-length' of - "0" -> - undefined; - _ -> - key_value_str(atom_to_list(Key), - Headers#http_request_h.'content-length') - end; -key_value_str(Key = 'content-location', Headers) -> - key_value_str(atom_to_list(Key), - Headers#http_request_h.'content-location'); -key_value_str(Key = 'content-md5', Headers) -> - key_value_str(atom_to_list(Key), - Headers#http_request_h.'content-md5'); -key_value_str(Key = 'content-range', Headers) -> - key_value_str(atom_to_list(Key), Headers#http_request_h.'content-range'); -key_value_str(Key = 'content-type', Headers) -> - key_value_str(atom_to_list(Key), Headers#http_request_h.'content-type'); -key_value_str(Key = expires, Headers) -> - key_value_str(atom_to_list(Key), Headers#http_request_h.expires); -key_value_str(Key = 'last-modified', Headers) -> - key_value_str(atom_to_list(Key), Headers#http_request_h.'last-modified'); -key_value_str(_, undefined) -> - undefined; -key_value_str(Key, Value) -> - Key ++ ": " ++ Value ++ ?CRLF. - -headers_other([], Headers) -> - Headers; -headers_other([{Key,Value} | Rest], Headers) -> - Header = Key ++ ": " ++ Value ++ ?CRLF, - headers_other(Rest, [Header | Headers]). diff --git a/src/couch_inets/http_response.erl b/src/couch_inets/http_response.erl deleted file mode 100644 index 27e807eb..00000000 --- a/src/couch_inets/http_response.erl +++ /dev/null @@ -1,206 +0,0 @@ -%% ``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$ - --module(http_response). - --include("http_internal.hrl"). - --export([headers/2, header_list/1]). - -%%------------------------------------------------------------------------- -%% headers(HeaderList, #http_response_h{}) -> #http_response_h{} -%% HeaderList - ["HeaderField:Value"] -%% HeaderField - string() -%% Value - string() -%% -%% Description: Creates a http_response_h-record used internally to -%% handle http-headers. -%%------------------------------------------------------------------------- -headers([], Headers) -> - Headers; - -headers([Header | Tail], Headers) -> - {Key, [$: | Value]} = - lists:splitwith(fun($:) -> false; (_) -> true end, Header), - headers(Tail, headers(http_util:to_lower(string:strip(Key)), - string:strip(Value), Headers)). - -%%------------------------------------------------------------------------- -%% headers(#http_response_h{}) -> HeaderList -%% HeaderList - [{"HeaderField", Value"}] -%% HeaderField - string() -%% Value - string() -%% -%% Description: Creates a list of key value tuples from the #http_response_h -%% record, to be returned to the application programmer. We -%% do not wish to make the application programmer dependent on -%% our records. -%%------------------------------------------------------------------------- -header_list(Headers) -> - HeaderFields = record_info(fields, http_response_h) -- [other], - HeaderList = lists:foldl(fun(Key, Acc) -> - case key_value_tuple(Key, Headers) of - undefined -> - Acc; - Tuple -> - [Tuple | Acc] - end - end, - [], HeaderFields), - lists:reverse(HeaderList) ++ Headers#http_response_h.other. -%%%======================================================================== -%%% Internal functions -%%%======================================================================== -headers("cache-control", Value, Headers) -> - Headers#http_response_h{'cache-control'= Value}; -headers("connection", Value, Headers) -> - Headers#http_response_h{connection = Value}; -headers("date", Value, Headers) -> - Headers#http_response_h{date = Value}; -headers("pragma", Value, Headers) -> - Headers#http_response_h{pragma = Value}; -headers("trailer", Value, Headers) -> - Headers#http_response_h{trailer = Value}; -headers("transfer-encoding", Value, Headers) -> - Headers#http_response_h{'transfer-encoding' = Value}; -headers("upgrade", Value, Headers) -> - Headers#http_response_h{upgrade = Value}; -headers("via", Value, Headers) -> - Headers#http_response_h{via = Value}; -headers("warning", Value, Headers) -> - Headers#http_response_h{warning = Value}; -headers("accept-ranges", Value, Headers) -> - Headers#http_response_h{'accept-ranges' = Value}; -headers("age", Value, Headers) -> - Headers#http_response_h{age = Value}; -headers("etag", Value, Headers) -> - Headers#http_response_h{etag = Value}; -headers("location", Value, Headers) -> - Headers#http_response_h{location = Value}; -headers("proxy-authenticate", Value, Headers) -> - Headers#http_response_h{'proxy-authenticate' = Value}; -headers("retry-after", Value, Headers) -> - Headers#http_response_h{'retry-after' = Value}; -headers("server", Value, Headers) -> - Headers#http_response_h{server = Value}; -headers("vary", Value, Headers) -> - Headers#http_response_h{vary = Value}; -headers("www-authenticate", Value, Headers) -> - Headers#http_response_h{'www-authenticate' = Value}; -headers("allow", Value, Headers) -> - Headers#http_response_h{allow = Value}; -headers("content-encoding", Value, Headers) -> - Headers#http_response_h{'content-encoding' = Value}; -headers("content-language", Value, Headers) -> - Headers#http_response_h{'content-language' = Value}; -headers("content-length", Value, Headers) -> - Headers#http_response_h{'content-length' = Value}; -headers("content-location", Value, Headers) -> - Headers#http_response_h{'content-location' = Value}; -headers("content-md5", Value, Headers) -> - Headers#http_response_h{'content-md5' = Value}; -headers("content-range", Value, Headers) -> - Headers#http_response_h{'content-range' = Value}; -headers("content-type", Value, Headers) -> - Headers#http_response_h{'content-type' = Value}; -headers("expires", Value, Headers) -> - Headers#http_response_h{expires = Value}; -headers("last-modified", Value, Headers) -> - Headers#http_response_h{'last-modified' = Value}; -headers(Key, Value, Headers) -> - Headers#http_response_h{other= - [{Key, Value} | Headers#http_response_h.other]}. - - -key_value_tuple(Key = 'cache-control', Headers) -> - key_value_tuple(atom_to_list(Key), - Headers#http_response_h.'cache-control'); -key_value_tuple(Key = connection, Headers) -> - key_value_tuple(atom_to_list(Key), Headers#http_response_h.connection); -key_value_tuple(Key = date, Headers) -> - key_value_tuple(atom_to_list(Key), Headers#http_response_h.date); -key_value_tuple(Key = pragma, Headers) -> - key_value_tuple(atom_to_list(Key), Headers#http_response_h.pragma); -key_value_tuple(Key = trailer, Headers) -> - key_value_tuple(atom_to_list(Key), Headers#http_response_h.trailer); -key_value_tuple(Key ='transfer-encoding', Headers) -> - key_value_tuple(atom_to_list(Key), - Headers#http_response_h.'transfer-encoding'); -key_value_tuple(Key = upgrade, Headers) -> - key_value_tuple(atom_to_list(Key), Headers#http_response_h.upgrade); -key_value_tuple(Key = via, Headers) -> - key_value_tuple(atom_to_list(Key), Headers#http_response_h.via); -key_value_tuple(Key = warning, Headers) -> - key_value_tuple(atom_to_list(Key), Headers#http_response_h.warning); -key_value_tuple(Key = 'accept-ranges', Headers) -> - key_value_tuple(atom_to_list(Key), - Headers#http_response_h.'accept-ranges'); -key_value_tuple(Key = age, Headers) -> - key_value_tuple(atom_to_list(Key), Headers#http_response_h.age); -key_value_tuple(Key = etag, Headers) -> - key_value_tuple(atom_to_list(Key), Headers#http_response_h.etag); -key_value_tuple(Key = location, Headers) -> - key_value_tuple(atom_to_list(Key), Headers#http_response_h.location); -key_value_tuple(Key = 'proxy-authenticate', Headers) -> - key_value_tuple(atom_to_list(Key), - Headers#http_response_h.'proxy-authenticate'); -key_value_tuple(Key = 'retry-after', Headers) -> - key_value_tuple(atom_to_list(Key), Headers#http_response_h.'retry-after'); -key_value_tuple(Key = server, Headers) -> - key_value_tuple(atom_to_list(Key), Headers#http_response_h.server); -key_value_tuple(Key = vary, Headers) -> - key_value_tuple(atom_to_list(Key), Headers#http_response_h.vary); -key_value_tuple(Key = 'www-authenticate', Headers) -> - key_value_tuple(atom_to_list(Key), - Headers#http_response_h.'www-authenticate'); -key_value_tuple(Key = allow, Headers) -> - key_value_tuple(atom_to_list(Key), Headers#http_response_h.allow); -key_value_tuple(Key = 'content-encoding', Headers) -> - key_value_tuple(atom_to_list(Key), - Headers#http_response_h.'content-encoding'); -key_value_tuple(Key = 'content-language', Headers) -> - key_value_tuple(atom_to_list(Key), - Headers#http_response_h.'content-language'); -key_value_tuple(Key = 'content-length', Headers) -> - case Headers#http_response_h.'content-length' of - "-1" -> - undefined; - _ -> - key_value_tuple(atom_to_list(Key), - Headers#http_response_h.'content-length') - end; -key_value_tuple(Key = 'content-location', Headers) -> - key_value_tuple(atom_to_list(Key), - Headers#http_response_h.'content-location'); -key_value_tuple(Key = 'content-md5', Headers) -> - key_value_tuple(atom_to_list(Key), - Headers#http_response_h.'content-md5'); -key_value_tuple(Key = 'content-range', Headers) -> - key_value_tuple(atom_to_list(Key), - Headers#http_response_h.'content-range'); -key_value_tuple(Key = 'content-type', Headers) -> - key_value_tuple(atom_to_list(Key), - Headers#http_response_h.'content-type'); -key_value_tuple(Key = expires, Headers) -> - key_value_tuple(atom_to_list(Key), Headers#http_response_h.expires); -key_value_tuple(Key = 'last-modified', Headers) -> - key_value_tuple(atom_to_list(Key), - Headers#http_response_h.'last-modified'); -key_value_tuple(_, undefined) -> - undefined; -key_value_tuple(Key, Value) -> - {Key, Value}. diff --git a/src/couch_inets/http_transport.erl b/src/couch_inets/http_transport.erl deleted file mode 100644 index 57787ef3..00000000 --- a/src/couch_inets/http_transport.erl +++ /dev/null @@ -1,291 +0,0 @@ -%% ``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$ -% --module(http_transport). - -% Internal application API --export([start/1, connect/3, connect/4, listen/2, listen/3, - accept/2, accept/3, close/2, - send/3, controlling_process/3, setopts/3, - peername/2, resolve/0]). - -%%%========================================================================= -%%% Internal application API -%%%========================================================================= - -%%------------------------------------------------------------------------- -%% start(SocketType) -> ok | {error, Reason} -%% SocketType = ip_comm | {ssl, _} -%% -%% Description: Makes sure inet_db or ssl is started. -%%------------------------------------------------------------------------- -start(ip_comm) -> - case inet_db:start() of - {ok, _} -> - ok; - {error, {already_started, _}} -> - ok; - Error -> - Error - end; -start({ssl, _}) -> - case ssl:start() of - ok -> - ok; - {ok, _} -> - ok; - {error, {already_started,_}} -> - ok; - Error -> - Error - end. - -%%------------------------------------------------------------------------- -%% connect(SocketType, Address, IPV6, Timeout) -> -%% {ok, Socket} | {error, Reason} -%% SocketType = ip_comm | {ssl, SslConfig} -%% Address = {Host, Port} -%% IPV6 = disabled | enabled -%% Socket = socket() -%% -%% Description: Connects to the Host and Port specified in HTTPRequest. -%% uses ipv6 if possible. -%%------------------------------------------------------------------------- -connect(SocketType, Address, IPV6) -> - connect(SocketType, Address, IPV6, infinity). - -connect(ip_comm, {Host, Port}, enabled, Timeout) -> - {Opts, NewHost} = - case inet:getaddr(Host, inet6) of - {ok, IPAddr = {0, 0, 0, 0, 0, 16#ffff, _, _}} -> - case inet:getaddr(Host, inet) of - {ok,NewIP} -> - {[binary, {packet, 0}, {active, false}, - {reuseaddr,true}], NewIP}; - _Error -> - {[binary, {packet, 0}, {active, false}, - {reuseaddr,true}, inet6], IPAddr} - end; - {ok, IPAddr} -> - {[binary, {packet, 0}, {active, false}, - {reuseaddr,true}, inet6], IPAddr}; - _ -> - {[binary, {packet, 0}, {active, false}, - {reuseaddr,true}], Host} - end, - gen_tcp:connect(NewHost, Port, Opts, Timeout); - -connect(ip_comm, {Host, Port}, disabled, Timeout) -> - Opts = [binary, {packet, 0}, {active, false}, {reuseaddr,true}], - gen_tcp:connect(Host, Port, Opts, Timeout); - -connect({ssl, SslConfig}, {Host, Port}, _, Timeout) -> - Opts = [binary, {active, false}] ++ SslConfig, - ssl:connect(Host, Port, Opts, Timeout). - -%%------------------------------------------------------------------------- -%% listen(SocketType, Port) -> {ok, Socket} | {error, Reason} -%% SocketType = ip_comm | {ssl, SSLConfig} -%% Port = integer() -%% Socket = socket() -%% -%% Description: Sets up socket to listen on the port Port on the local -%% host using either gen_tcp or ssl. In the gen_tcp case the port -%% might allready have been initiated by a wrapper-program and is -%% given as an Fd that can be retrieved by init:get_argument. The -%% reason for this to enable a HTTP-server not runnig as root to use -%% port 80. -%%------------------------------------------------------------------------- -listen(SocketType, Port) -> - listen(SocketType, undefined, Port). - -listen(ip_comm, Addr, Port) -> - FdName = list_to_atom("httpd_" ++ integer_to_list(Port)), - {NewPort, Opt} = - case init:get_argument(FdName) of - {ok, [[FdStr]]} -> - Fd = list_to_integer(FdStr), - {0, - sock_opt(ip_comm, Addr, [{backlog, 128}, - {reuseaddr,true}, {fd,Fd}, {nodelay, true}])}; - error -> - {Port, - sock_opt(ip_comm, Addr, - [{backlog, 128}, {reuseaddr, true}, {nodelay, true}])} - end, - gen_tcp:listen(NewPort, Opt); - -listen({ssl, SSLConfig} = Ssl, Addr, Port) -> - Opt = sock_opt(Ssl, Addr, SSLConfig), - ssl:listen(Port, Opt). - -%%------------------------------------------------------------------------- -%% accept(SocketType, ListenSocket) -> {ok, Socket} | {error, Reason} -%% accept(SocketType, ListenSocket, Timeout) -> ok | {error, Reason} -%% SocketType = ip_comm | {ssl, SSLConfig} -%% ListenSocket = socket() -%% Timeout = infinity | integer() >= 0 -%% Socket = socket() -%% -%% Description: Accepts an incoming connection request on a listen socket, -%% using either gen_tcp or ssl. -%%------------------------------------------------------------------------- -accept(SocketType, ListenSocket) -> - accept(SocketType, ListenSocket, infinity). -accept(ip_comm, ListenSocket, Timeout) -> - gen_tcp:accept(ListenSocket, Timeout); -accept({ssl,_SSLConfig}, ListenSocket, Timeout) -> - ssl:accept(ListenSocket, Timeout). - -%%------------------------------------------------------------------------- -%% controlling_process(SocketType, Socket, NewOwner) -> ok | {error, Reason} -%% SocketType = ip_comm | {ssl, _} -%% Socket = socket() -%% NewOwner = pid() -%% -%% Description: Assigns a new controlling process to Socket. -%%------------------------------------------------------------------------- -controlling_process(ip_comm, Socket, NewOwner) -> - gen_tcp:controlling_process(Socket, NewOwner); -controlling_process({ssl, _}, Socket, NewOwner) -> - ssl:controlling_process(Socket, NewOwner). - -%%------------------------------------------------------------------------- -%% setopts(SocketType, Socket, Options) -> ok | {error, Reason} -%% SocketType = ip_comm | {ssl, _} -%% Socket = socket() -%% Options = list() -%% Description: Sets one or more options for a socket, using either -%% gen_tcp or ssl. -%%------------------------------------------------------------------------- -setopts(ip_comm, Socket, Options) -> - inet:setopts(Socket,Options); -setopts({ssl, _}, Socket, Options) -> - ssl:setopts(Socket, Options). - -%%------------------------------------------------------------------------- -%% send(RequestOrSocketType, Socket, Message) -> ok | {error, Reason} -%% SocketType = ip_comm | {ssl, _} -%% Socket = socket() -%% Message = list() | binary() -%% Description: Sends a packet on a socket, using either gen_tcp or ssl. -%%------------------------------------------------------------------------- -send(ip_comm, Socket, Message) -> - gen_tcp:send(Socket, Message); -send({ssl, _}, Socket, Message) -> - ssl:send(Socket, Message). - -%%------------------------------------------------------------------------- -%% close(SocketType, Socket) -> ok | {error, Reason} -%% SocketType = ip_comm | {ssl, _} -%% Socket = socket() -%% -%% Description: Closes a socket, using either gen_tcp or ssl. -%%------------------------------------------------------------------------- -close(ip_comm, Socket) -> - gen_tcp:close(Socket); -close({ssl, _}, Socket) -> - ssl:close(Socket). - -%%------------------------------------------------------------------------- -%% peername(SocketType, Socket) -> ok | {error, Reason} -%% SocketType = ip_comm | {ssl, _} -%% Socket = socket() -%% -%% Description: Returns the address and port for the other end of a -%% connection, usning either gen_tcp or ssl. -%%------------------------------------------------------------------------- -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), - {Port, PeerName}; - {ok,{{A, B, C, D, E, F, G, H}, Port}} -> - PeerName = http_util:integer_to_hexlist(A) ++ ":"++ - http_util:integer_to_hexlist(B) ++ ":" ++ - http_util:integer_to_hexlist(C) ++ ":" ++ - http_util:integer_to_hexlist(D) ++ ":" ++ - http_util:integer_to_hexlist(E) ++ ":" ++ - http_util:integer_to_hexlist(F) ++ ":" ++ - http_util:integer_to_hexlist(G) ++":"++ - http_util:integer_to_hexlist(H), - {Port, PeerName}; - {error, _} -> - {-1, "unknown"} - end; - -peername({ssl, _}, 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), - {Port, PeerName}; - {error, _} -> - {-1, "unknown"} - end. - -%%------------------------------------------------------------------------- -%% resolve() -> HostName -%% HostName = string() -%% -%% Description: Returns the local hostname. -%%------------------------------------------------------------------------- -resolve() -> - {ok, Name} = inet:gethostname(), - Name. - - -%%%======================================================================== -%%% Internal functions -%%%======================================================================== - -%% Address any comes from directive: BindAddress "*" -sock_opt(ip_comm, any = Addr, Opt) -> - sock_opt1([{ip, Addr} | Opt]); -sock_opt(ip_comm, undefined, Opt) -> - sock_opt1(Opt); -sock_opt(_, any = Addr, Opt) -> - sock_opt2([{ip, Addr} | Opt]); -sock_opt(_, undefined, Opt) -> - sock_opt2(Opt); -sock_opt(_, Addr, Opt) when size(Addr) == 4 -> - sock_opt2([{ip, Addr} | Opt]); -sock_opt(ip_comm, Addr, Opt) -> - sock_opt2([inet6, {ip, Addr} | Opt]); -sock_opt(_, Addr, Opt) -> - sock_opt2([{ip, Addr} | Opt]). - -sock_opt1(Opt) -> - case has_inet6_supported() of - yes -> - sock_opt2([inet6 | Opt]); - no -> - sock_opt2(Opt) - end. - -sock_opt2(Opt) -> - [{packet, 0}, {active, false} | Opt]. - -has_inet6_supported() -> - case (catch inet:getaddr("localhost", inet6)) of - {ok, {0, 0, 0, 0, 0, 16#ffff, _, _}} -> - no; - {ok,_} -> yes; - _ -> - no - end. diff --git a/src/couch_inets/http_uri.erl b/src/couch_inets/http_uri.erl deleted file mode 100644 index 8e2be1a9..00000000 --- a/src/couch_inets/http_uri.erl +++ /dev/null @@ -1,113 +0,0 @@ -% ``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$ -%% --module(http_uri). - --export([parse/1]). - -%%%========================================================================= -%%% API -%%%========================================================================= -parse(AbsURI) -> - case parse_scheme(AbsURI) of - {error, Reason} -> - {error, Reason}; - {Scheme, Rest} -> - case (catch parse_uri_rest(Scheme, Rest)) of - {UserInfo, Host, Port, Path, Query} -> - {Scheme, UserInfo, Host, Port, Path, Query}; - _ -> - {error, {malformed_url, AbsURI}} - end - end. - -%%%======================================================================== -%%% Internal functions -%%%======================================================================== -parse_scheme(AbsURI) -> - case split_uri(AbsURI, ":", {error, no_scheme}, 1, 1) of - {error, no_scheme} -> - {error, no_scheme}; - {StrScheme, Rest} -> - case list_to_atom(http_util:to_lower(StrScheme)) of - Scheme when Scheme == http; Scheme == https -> - {Scheme, Rest}; - Scheme -> - {error, {not_supported_scheme, Scheme}} - end - end. - -parse_uri_rest(Scheme, "//" ++ URIPart) -> - - {Authority, PathQuery} = - case split_uri(URIPart, "/", URIPart, 1, 0) of - Split = {_, _} -> - Split; - URIPart -> - case split_uri(URIPart, "\\?", URIPart, 1, 0) of - Split = {_, _} -> - Split; - URIPart -> - {URIPart,""} - end - end, - - {UserInfo, HostPort} = split_uri(Authority, "@", {"", Authority}, 1, 1), - {Host, Port} = parse_host_port(Scheme, HostPort), - {Path, Query} = parse_path_query(PathQuery), - {UserInfo, Host, Port, Path, Query}. - - -parse_path_query(PathQuery) -> - {Path, Query} = split_uri(PathQuery, "\\?", {PathQuery, ""}, 1, 0), - {path(Path), Query}. - - -parse_host_port(Scheme,"[" ++ HostPort) -> %ipv6 - DefaultPort = default_port(Scheme), - {Host, ColonPort} = split_uri(HostPort, "\\]", {HostPort, ""}, 1, 1), - {_, Port} = split_uri(ColonPort, ":", {"", DefaultPort}, 0, 1), - {Host, int_port(Port)}; - -parse_host_port(Scheme, HostPort) -> - DefaultPort = default_port(Scheme), - {Host, Port} = split_uri(HostPort, ":", {HostPort, DefaultPort}, 1, 1), - {Host, int_port(Port)}. - -split_uri(UriPart, SplitChar, NoMatchResult, SkipLeft, SkipRight) -> - case regexp:first_match(UriPart, SplitChar) of - {match, Match, _} -> - {string:substr(UriPart, 1, Match - SkipLeft), - string:substr(UriPart, Match + SkipRight, length(UriPart))}; - nomatch -> - NoMatchResult - end. - -default_port(http) -> - 80; -default_port(https) -> - 443. - -int_port(Port) when is_integer(Port) -> - Port; -int_port(Port) when is_list(Port) -> - list_to_integer(Port). - -path("") -> - "/"; -path(Path) -> - Path. diff --git a/src/couch_inets/http_util.erl b/src/couch_inets/http_util.erl deleted file mode 100644 index 7396fec6..00000000 --- a/src/couch_inets/http_util.erl +++ /dev/null @@ -1,171 +0,0 @@ -%% ``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$ -%% --module(http_util). - --export([key1search/2, key1search/3, - to_upper/1, to_lower/1, convert_netscapecookie_date/1, - hexlist_to_integer/1, integer_to_hexlist/1, - convert_month/1, is_hostname/1]). - -%%%========================================================================= -%%% Internal application API -%%%========================================================================= -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. - -to_upper(Str) -> - to_upper(Str, []). - -to_upper([C|Cs], Acc) when C >= $a, C =< $z -> - to_upper(Cs, [C-($a-$A)| Acc]); -to_upper([C|Cs], Acc) -> - to_upper(Cs, [C | Acc]); -to_upper([], Acc) -> - lists:reverse(Acc). - -to_lower(Str) -> - to_lower(Str, []). -to_lower([C|Cs], Acc) when C >= $A, C =< $Z -> - to_lower(Cs, [C+($a-$A)| Acc]); -to_lower([C|Cs], Acc) -> - to_lower(Cs, [C| Acc]); -to_lower([], Acc) -> - lists:reverse(Acc). - -convert_netscapecookie_date([_D,_A,_Y, $,, _SP, - D1,D2,_DA, - M,O,N,_DA, - 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]), - {{Year,Month,Day},{Hour,Min,Sec}}; - -convert_netscapecookie_date([_D,_A,_Y, _SP, - D1,D2,_DA, - M,O,N,_DA, - 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]), - {{Year,Month,Day},{Hour,Min,Sec}}. - -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). - -integer_to_hexlist(Num)-> - integer_to_hexlist(Num, get_size(Num), []). - -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. - -is_hostname(Dest) -> - inet_parse:domain(Dest). - -%%%======================================================================== -%%% Internal functions -%%%======================================================================== -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. - -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]). - -get_size(Num)-> - get_size(Num, 0). - -get_size(Num, Pot) when Num < (16 bsl(Pot *4)) -> - Pot-1; - -get_size(Num, Pot) -> - get_size(Num, Pot+1). - -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]). diff --git a/src/couch_inets/httpc_handler.erl b/src/couch_inets/httpc_handler.erl deleted file mode 100644 index 8019b72b..00000000 --- a/src/couch_inets/httpc_handler.erl +++ /dev/null @@ -1,953 +0,0 @@ -% ``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$ - --module(httpc_handler). - --behaviour(gen_server). - --include("httpc_internal.hrl"). --include("http_internal.hrl"). - -%%-------------------------------------------------------------------- -%% Application API --export([start_link/2, send/2, cancel/2, stream/3]). - -%% gen_server callbacks --export([init/1, handle_call/3, handle_cast/2, handle_info/2, - terminate/2, code_change/3]). - --record(timers, {request_timers = [], % [ref()] - pipeline_timer % ref() - }). - --record(state, {request, % #request{} - session, % #tcp_session{} - status_line, % {Version, StatusCode, ReasonPharse} - headers, % #http_response_h{} - body, % binary() - mfa, % {Moduel, Function, Args} - pipeline = queue:new(),% queue() - status = new, % new | pipeline | close | ssl_tunnel - canceled = [], % [RequestId] - max_header_size = nolimit, % nolimit | integer() - max_body_size = nolimit, % nolimit | integer() - options, % #options{} - timers = #timers{} % #timers{} - }). - -%%==================================================================== -%% External functions -%%==================================================================== -%%-------------------------------------------------------------------- -%% Function: start() -> {ok, Pid} -%% -%% Description: Starts a http-request handler process. Intended to be -%% called by the httpc manager process. -%% -%% Note: Uses proc_lib and gen_server:enter_loop so that waiting -%% for gen_tcp:connect to timeout in init/1 will not -%% block the httpc manager process in odd cases such as trying to call -%% a server that does not exist. (See OTP-6735) The only API function -%% sending messages to the handler process that can be called before -%% init has compleated is cancel and that is not a problem! (Send and -%% stream will not be called before the first request has been sent and -%% the reply or part of it has arrived.) -%%-------------------------------------------------------------------- -start_link(Request, ProxyOptions) -> - {ok, proc_lib:spawn_link(?MODULE, init, [[Request, ProxyOptions]])}. - -%%-------------------------------------------------------------------- -%% Function: send(Request, Pid) -> ok -%% Request = #request{} -%% Pid = pid() - the pid of the http-request handler process. -%% -%% Description: Uses this handlers session to send a request. Intended -%% to be called by the httpc manager process. -%%-------------------------------------------------------------------- -send(Request, Pid) -> - call(Request, Pid, 5000). - -%%-------------------------------------------------------------------- -%% Function: cancel(RequestId, Pid) -> ok -%% RequestId = ref() -%% Pid = pid() - the pid of the http-request handler process. -%% -%% Description: Cancels a request. Intended to be called by the httpc -%% manager process. -%%-------------------------------------------------------------------- -cancel(RequestId, Pid) -> - cast({cancel, RequestId}, Pid). - -%%-------------------------------------------------------------------- -%% Function: stream(BodyPart, Request, Code) -> _ -%% BodyPart = binary() -%% Request = #request{} -%% Code = integer() -%% -%% Description: Stream the HTTP body to the caller process (client) -%% or to a file. Note that the data that has been stream -%% does not have to be saved. (We do not want to use up -%% memory in vain.) -%%-------------------------------------------------------------------- -%% Request should not be streamed -stream(BodyPart, Request = #request{stream = none}, _) -> - {BodyPart, Request}; - -stream(BodyPart, Request = #request{stream = self}, 200) -> % Stream to caller - httpc_response:send(Request#request.from, - {Request#request.id, stream, BodyPart}), - {<<>>, Request}; - -stream(BodyPart, Request = #request{stream = Filename}, 200) - when is_list(Filename) -> % Stream to file - case file:open(Filename, [write, raw, append, delayed_write]) of - {ok, Fd} -> - stream(BodyPart, Request#request{stream = Fd}, 200); - {error, Reason} -> - exit({stream_to_file_failed, Reason}) - end; - -stream(BodyPart, Request = #request{stream = Fd}, 200) -> % Stream to file - case file:write(Fd, BodyPart) of - ok -> - {<<>>, Request}; - {error, Reason} -> - exit({stream_to_file_failed, Reason}) - end; -stream(BodyPart, Request,_) -> % only 200 responses can be streamed - {BodyPart, Request}. - -%%==================================================================== -%% Server functions -%%==================================================================== - -%%-------------------------------------------------------------------- -%% Function: init([Request, Session]) -> {ok, State} | -%% {ok, State, Timeout} | ignore |{stop, Reason} -%% -%% Description: Initiates the httpc_handler process -%% -%% Note: The init function may not fail, that will kill the -%% httpc_manager process. We could make the httpc_manager more comlex -%% but we do not want that so errors will be handled by the process -%% sending an init_error message to itself. -%%-------------------------------------------------------------------- -init([Request, Options]) -> - process_flag(trap_exit, true), - handle_verbose(Options#options.verbose), - Address = handle_proxy(Request#request.address, Options#options.proxy), - {ok, State} = - case {Address /= Request#request.address, Request#request.scheme} of - {true, https} -> - Error = https_through_proxy_is_not_currently_supported, - self() ! {init_error, - Error, httpc_response:error(Request, Error)}, - {ok, #state{request = Request, options = Options, - status = ssl_tunnel}}; - %% This is what we should do if and when ssl supports - %% "socket upgrading" - %%send_ssl_tunnel_request(Address, Request, - %% #state{options = Options, - %% status = ssl_tunnel}); - {_, _} -> - send_first_request(Address, Request, #state{options = Options}) - end, - gen_server:enter_loop(?MODULE, [], State). - -%%-------------------------------------------------------------------- -%% Function: handle_call(Request, From, State) -> {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) -%% Description: Handling call messages -%%-------------------------------------------------------------------- -handle_call(Request, _, State = #state{session = Session = - #tcp_session{socket = Socket}, - timers = Timers, - options = Options}) -> - Address = handle_proxy(Request#request.address, Options#options.proxy), - - case httpc_request:send(Address, Request, Socket) of - ok -> - %% Activate the request time out for the new request - NewState = activate_request_timeout(State#state{request = - Request}), - - ClientClose = httpc_request:is_client_closing( - Request#request.headers), - case State#state.request of - #request{} -> %% Old request no yet finished - %% Make sure to use the new value of timers in state - NewTimers = NewState#state.timers, - NewPipeline = queue:in(Request, State#state.pipeline), - NewSession = - Session#tcp_session{pipeline_length = - %% Queue + current - queue:len(NewPipeline) + 1, - client_close = ClientClose}, - httpc_manager:insert_session(NewSession), - {reply, ok, State#state{pipeline = NewPipeline, - session = NewSession, - timers = NewTimers}}; - undefined -> - %% Note: tcp-message reciving has already been - %% activated by handle_pipeline/2. Also - %% the parsing-function #state.mfa is initiated - %% by handle_pipeline/2. - cancel_timer(Timers#timers.pipeline_timer, - timeout_pipeline), - NewSession = - Session#tcp_session{pipeline_length = 1, - client_close = ClientClose}, - httpc_manager:insert_session(NewSession), - {reply, ok, - NewState#state{request = Request, - session = NewSession, - timers = - Timers#timers{pipeline_timer = - undefined}}} - end; - {error, Reason} -> - {reply, {pipline_failed, Reason}, State} - end. -%%-------------------------------------------------------------------- -%% Function: handle_cast(Msg, State) -> {noreply, State} | -%% {noreply, State, Timeout} | -%% {stop, Reason, State} (terminate/2 is called) -%% Description: Handling cast messages -%%-------------------------------------------------------------------- - -%% When the request in process has been canceld the handler process is -%% stopped and the pipelined requests will be reissued. This is is -%% based on the assumption that it is proably cheaper to reissue the -%% requests than to wait for a potentiall large response that we then -%% only throw away. This of course is not always true maybe we could -%% do something smarter here?! If the request canceled is not -%% the one handled right now the same effect will take place in -%% handle_pipeline/2 when the canceled request is on turn. -handle_cast({cancel, RequestId}, State = #state{request = Request = - #request{id = RequestId}}) -> - httpc_manager:request_canceled(RequestId), - {stop, normal, - State#state{canceled = [RequestId | State#state.canceled], - request = Request#request{from = answer_sent}}}; -handle_cast({cancel, RequestId}, State) -> - httpc_manager:request_canceled(RequestId), - {noreply, State#state{canceled = [RequestId | State#state.canceled]}}. - -%%-------------------------------------------------------------------- -%% Function: handle_info(Info, State) -> {noreply, State} | -%% {noreply, State, Timeout} | -%% {stop, Reason, State} (terminate/2 is called) -%% Description: Handling all non call/cast messages -%%-------------------------------------------------------------------- -handle_info({Proto, _Socket, Data}, State = - #state{mfa = {Module, Function, Args}, - request = #request{method = Method, - stream = Stream} = Request, - session = Session, status_line = StatusLine}) - when Proto == tcp; Proto == ssl; Proto == httpc_handler -> - - case Module:Function([Data | Args]) of - {ok, Result} -> - handle_http_msg(Result, State); - {_, whole_body, _} when Method == head -> - handle_response(State#state{body = <<>>}); - {Module, whole_body, [Body, Length]} -> - {_, Code, _} = StatusLine, - {NewBody, NewRequest} = stream(Body, Request, Code), - %% When we stream we will not keep the already - %% streamed data, that would be a waste of memory. - NewLength = case Stream of - none -> - Length; - _ -> - Length - size(Body) - end, - http_transport:setopts(socket_type(Session#tcp_session.scheme), - Session#tcp_session.socket, - [{active, once}]), - {noreply, State#state{mfa = {Module, whole_body, - [NewBody, NewLength]}, - request = NewRequest}}; - NewMFA -> - http_transport:setopts(socket_type(Session#tcp_session.scheme), - Session#tcp_session.socket, - [{active, once}]), - {noreply, State#state{mfa = NewMFA}} - end; - -%% The Server may close the connection to indicate that the -%% whole body is now sent instead of sending an lengh -%% indicator. -handle_info({tcp_closed, _}, State = #state{mfa = {_, whole_body, Args}}) -> - handle_response(State#state{body = hd(Args)}); -handle_info({ssl_closed, _}, State = #state{mfa = {_, whole_body, Args}}) -> - handle_response(State#state{body = hd(Args)}); - -%%% Server closes idle pipeline -handle_info({tcp_closed, _}, State = #state{request = undefined}) -> - {stop, normal, State}; -handle_info({ssl_closed, _}, State = #state{request = undefined}) -> - {stop, normal, State}; - -%%% Error cases -handle_info({tcp_closed, _}, State) -> - {stop, session_remotly_closed, State}; -handle_info({ssl_closed, _}, State) -> - {stop, session_remotly_closed, State}; -handle_info({tcp_error, _, _} = Reason, State) -> - {stop, Reason, State}; -handle_info({ssl_error, _, _} = Reason, State) -> - {stop, Reason, State}; - -%%% Timeouts -%% Internaly, to a request handling process, a request time out is -%% seen as a canceld request. -handle_info({timeout, RequestId}, State = - #state{request = Request = #request{id = RequestId}}) -> - httpc_response:send(Request#request.from, - httpc_response:error(Request,timeout)), - {stop, normal, - State#state{canceled = [RequestId | State#state.canceled], - request = Request#request{from = answer_sent}}}; -handle_info({timeout, RequestId}, State = #state{request = Request}) -> - httpc_response:send(Request#request.from, - httpc_response:error(Request,timeout)), - {noreply, State#state{canceled = [RequestId | State#state.canceled]}}; - -handle_info(timeout_pipeline, State = #state{request = undefined}) -> - {stop, normal, State}; - -%% Setting up the connection to the server somehow failed. -handle_info({init_error, _, ClientErrMsg}, - State = #state{request = Request}) -> - NewState = answer_request(Request, ClientErrMsg, State), - {stop, normal, NewState}; - -%%% httpc_manager process dies. -handle_info({'EXIT', _, _}, State = #state{request = undefined}) -> - {stop, normal, State}; -%%Try to finish the current request anyway, -%% there is a fairly high probability that it can be done successfully. -%% Then close the connection, hopefully a new manager is started that -%% can retry requests in the pipeline. -handle_info({'EXIT', _, _}, State) -> - {noreply, State#state{status = close}}. - -%%-------------------------------------------------------------------- -%% Function: terminate(Reason, State) -> _ (ignored by gen_server) -%% Description: Shutdown the httpc_handler -%%-------------------------------------------------------------------- -terminate(normal, #state{session = undefined}) -> - ok; %% Init error there is no socket to be closed. -terminate(normal, #state{request = Request, - session = #tcp_session{id = undefined, - socket = Socket}}) -> - %% Init error sending, no session information has been setup but - %% there is a socket that needs closing. - http_transport:close(socket_type(Request), Socket); - -terminate(_, State = #state{session = Session, request = undefined, - timers = Timers}) -> - catch httpc_manager:delete_session(Session#tcp_session.id), - - case queue:is_empty(State#state.pipeline) of - false -> - retry_pipline(queue:to_list(State#state.pipeline), State); - true -> - ok - end, - cancel_timer(Timers#timers.pipeline_timer, timeout_pipeline), - http_transport:close(socket_type(Session#tcp_session.scheme), - Session#tcp_session.socket); - -terminate(Reason, State = #state{request = Request})-> - NewState = case Request#request.from of - answer_sent -> - State; - _ -> - answer_request(Request, - httpc_response:error(Request, Reason), - State) - end, - terminate(Reason, NewState#state{request = undefined}). - - -%%-------------------------------------------------------------------- -%% Func: code_change(_OldVsn, State, Extra) -> {ok, NewState} -%% Purpose: Convert process state when code is changed -%%-------------------------------------------------------------------- -code_change(_, State, _Extra) -> - {ok, State}. - -%%-------------------------------------------------------------------- -%%% Internal functions -%%-------------------------------------------------------------------- -send_first_request(Address, Request, State) -> - Ipv6 = (State#state.options)#options.ipv6, - SocketType = socket_type(Request), - TimeOut = (Request#request.settings)#http_options.timeout, - case http_transport:connect(SocketType, Address, Ipv6, TimeOut) of - {ok, Socket} -> - case httpc_request:send(Address, Request, Socket) of - ok -> - ClientClose = - httpc_request:is_client_closing( - Request#request.headers), - Session = - #tcp_session{id = {Request#request.address, self()}, - scheme = Request#request.scheme, - socket = Socket, - client_close = ClientClose}, - TmpState = State#state{request = Request, - session = Session, - mfa = - {httpc_response, parse, - [State#state.max_header_size]}, - status_line = undefined, - headers = undefined, - body = undefined, - status = new}, - http_transport:setopts(SocketType, - Socket, [{active, once}]), - NewState = activate_request_timeout(TmpState), - {ok, NewState}; - {error, Reason} -> - %% Commented out in wait of ssl support to avoid - %% dialyzer warning - %%case State#state.status of - %% new -> % Called from init/1 - self() ! {init_error, error_sending, - httpc_response:error(Request, Reason)}, - {ok, State#state{request = Request, - session = - #tcp_session{socket = Socket}}} - %%ssl_tunnel -> % Not called from init/1 - %% NewState = - %% answer_request(Request, - %%httpc_response:error(Request, - %%Reason), - %% State), - %% {stop, normal, NewState} - %% end - end; - {error, Reason} -> - %% Commented out in wait of ssl support to avoid - %% dialyzer warning - %% case State#state.status of - %% new -> % Called from init/1 - self() ! {init_error, error_connecting, - httpc_response:error(Request, Reason)}, - {ok, State#state{request = Request}} - %% ssl_tunnel -> % Not called from init/1 - %% NewState = - %% answer_request(Request, - %% httpc_response:error(Request, - %% Reason), - %% State), - %% {stop, normal, NewState} - %%end - end. - -handle_http_msg({Version, StatusCode, ReasonPharse, Headers, Body}, - State = #state{request = Request}) -> - - case Headers#http_response_h.'content-type' of - "multipart/byteranges" ++ _Param -> - exit(not_yet_implemented); - _ -> - start_stream({{Version, StatusCode, ReasonPharse}, Headers}, - Request), - handle_http_body(Body, - State#state{status_line = {Version, - StatusCode, - ReasonPharse}, - headers = Headers}) - end; -handle_http_msg({ChunkedHeaders, Body}, - State = #state{headers = Headers}) -> - NewHeaders = http_chunk:handle_headers(Headers, ChunkedHeaders), - handle_response(State#state{headers = NewHeaders, body = Body}); -handle_http_msg(Body, State = #state{status_line = {_,Code, _}}) -> - {NewBody, NewRequest}= stream(Body, State#state.request, Code), - handle_response(State#state{body = NewBody, request = NewRequest}). - -handle_http_body(<<>>, State = #state{request = #request{method = head}}) -> - handle_response(State#state{body = <<>>}); - -handle_http_body(Body, State = #state{headers = Headers, session = Session, - max_body_size = MaxBodySize, - status_line = {_,Code, _}, - request = Request}) -> - case Headers#http_response_h.'transfer-encoding' of - "chunked" -> - case http_chunk:decode(Body, State#state.max_body_size, - State#state.max_header_size, - {Code, Request}) of - {Module, Function, Args} -> - http_transport:setopts(socket_type( - Session#tcp_session.scheme), - Session#tcp_session.socket, - [{active, once}]), - {noreply, State#state{mfa = - {Module, Function, Args}}}; - {ok, {ChunkedHeaders, NewBody}} -> - NewHeaders = http_chunk:handle_headers(Headers, - ChunkedHeaders), - handle_response(State#state{headers = NewHeaders, - body = NewBody}) - end; - Encoding when list(Encoding) -> - NewState = answer_request(Request, - httpc_response:error(Request, - unknown_encoding), - State), - {stop, normal, NewState}; - _ -> - Length = - list_to_integer(Headers#http_response_h.'content-length'), - case ((Length =< MaxBodySize) or (MaxBodySize == nolimit)) of - true -> - case httpc_response:whole_body(Body, Length) of - {ok, Body} -> - {NewBody, NewRequest}= stream(Body, Request, Code), - handle_response(State#state{body = NewBody, - request = NewRequest}); - MFA -> - http_transport:setopts( - socket_type(Session#tcp_session.scheme), - Session#tcp_session.socket, - [{active, once}]), - {noreply, State#state{mfa = MFA}} - end; - false -> - NewState = - answer_request(Request, - httpc_response:error(Request, - body_too_big), - State), - {stop, normal, NewState} - end - end. - -%%% Normaly I do not comment out code, I throw it away. But this might -%%% actually be used on day if ssl is improved. -%% handle_response(State = #state{status = ssl_tunnel, -%% request = Request, -%% options = Options, -%% session = #tcp_session{socket = Socket, -%% scheme = Scheme}, -%% status_line = {_, 200, _}}) -> -%% %%% Insert code for upgrading the socket if and when ssl supports this. -%% Address = handle_proxy(Request#request.address, Options#options.proxy), -%% send_first_request(Address, Request, State); -%% handle_response(State = #state{status = ssl_tunnel, -%% request = Request}) -> -%% NewState = answer_request(Request, -%% httpc_response:error(Request, -%% ssl_proxy_tunnel_failed), -%% State), -%% {stop, normal, NewState}; - -handle_response(State = #state{status = new}) -> - handle_response(try_to_enable_pipline(State)); - -handle_response(State = #state{request = Request, - status = Status, - session = Session, - status_line = StatusLine, - headers = Headers, - body = Body, - options = Options}) when Status =/= new -> - - handle_cookies(Headers, Request, Options), - case httpc_response:result({StatusLine, Headers, Body}, Request) of - %% 100-continue - continue -> - %% Send request body - {_, RequestBody} = Request#request.content, - http_transport:send(socket_type(Session#tcp_session.scheme), - Session#tcp_session.socket, - RequestBody), - %% Wait for next response - http_transport:setopts(socket_type(Session#tcp_session.scheme), - Session#tcp_session.socket, - [{active, once}]), - {noreply, - State#state{mfa = {httpc_response, parse, - [State#state.max_header_size]}, - status_line = undefined, - headers = undefined, - body = undefined - }}; - %% Ignore unexpected 100-continue response and receive the - %% actual response that the server will send right away. - {ignore, Data} -> - NewState = State#state{mfa = - {httpc_response, parse, - [State#state.max_header_size]}, - status_line = undefined, - headers = undefined, - body = undefined}, - handle_info({httpc_handler, dummy, Data}, NewState); - %% On a redirect or retry the current request becomes - %% obsolete and the manager will create a new request - %% with the same id as the current. - {redirect, NewRequest, Data}-> - ok = httpc_manager:redirect_request(NewRequest), - handle_pipeline(State#state{request = undefined}, Data); - {retry, TimeNewRequest, Data}-> - ok = httpc_manager:retry_request(TimeNewRequest), - handle_pipeline(State#state{request = undefined}, Data); - {ok, Msg, Data} -> - end_stream(StatusLine, Request), - NewState = answer_request(Request, Msg, State), - handle_pipeline(NewState, Data); - {stop, Msg} -> - end_stream(StatusLine, Request), - NewState = answer_request(Request, Msg, State), - {stop, normal, NewState} - end. - -handle_cookies(_,_, #options{cookies = disabled}) -> - ok; -%% User wants to verify the cookies before they are stored, -%% so the user will have to call a store command. -handle_cookies(_,_, #options{cookies = verify}) -> - ok; -handle_cookies(Headers, Request, #options{cookies = enabled}) -> - {Host, _ } = Request#request.address, - Cookies = http_cookie:cookies(Headers#http_response_h.other, - Request#request.path, Host), - httpc_manager:store_cookies(Cookies, Request#request.address). - -%% This request could not be pipelined -handle_pipeline(State = #state{status = close}, _) -> - {stop, normal, State}; - -handle_pipeline(State = #state{status = pipeline, session = Session}, - Data) -> - case queue:out(State#state.pipeline) of - {empty, _} -> - %% The server may choose too teminate an idle pipeline - %% in this case we want to receive the close message - %% at once and not when trying to pipline the next - %% request. - http_transport:setopts(socket_type(Session#tcp_session.scheme), - Session#tcp_session.socket, - [{active, once}]), - %% If a pipeline that has been idle for some time is not - %% closed by the server, the client may want to close it. - NewState = activate_pipeline_timeout(State), - NewSession = Session#tcp_session{pipeline_length = 0}, - httpc_manager:insert_session(NewSession), - {noreply, - NewState#state{request = undefined, - mfa = {httpc_response, parse, - [NewState#state.max_header_size]}, - status_line = undefined, - headers = undefined, - body = undefined - } - }; - {{value, NextRequest}, Pipeline} -> - case lists:member(NextRequest#request.id, - State#state.canceled) of - true -> - %% See comment for handle_cast({cancel, RequestId}) - {stop, normal, - State#state{request = - NextRequest#request{from = answer_sent}}}; - false -> - NewSession = - Session#tcp_session{pipeline_length = - %% Queue + current - queue:len(Pipeline) + 1}, - httpc_manager:insert_session(NewSession), - NewState = - State#state{pipeline = Pipeline, - request = NextRequest, - mfa = {httpc_response, parse, - [State#state.max_header_size]}, - status_line = undefined, - headers = undefined, - body = undefined}, - case Data of - <<>> -> - http_transport:setopts( - socket_type(Session#tcp_session.scheme), - Session#tcp_session.socket, - [{active, once}]), - {noreply, NewState}; - _ -> - %% If we already received some bytes of - %% the next response - handle_info({httpc_handler, dummy, Data}, - NewState) - end - end - end. - -call(Msg, Pid, Timeout) -> - gen_server:call(Pid, Msg, Timeout). - -cast(Msg, Pid) -> - gen_server:cast(Pid, Msg). - -activate_request_timeout(State = #state{request = Request}) -> - Time = (Request#request.settings)#http_options.timeout, - case Time of - infinity -> - State; - _ -> - Ref = erlang:send_after(Time, self(), - {timeout, Request#request.id}), - State#state - {timers = - #timers{request_timers = - [{Request#request.id, Ref}| - (State#state.timers)#timers.request_timers]}} - end. - -activate_pipeline_timeout(State = #state{options = - #options{pipeline_timeout = - infinity}}) -> - State; -activate_pipeline_timeout(State = #state{options = - #options{pipeline_timeout = Time}}) -> - Ref = erlang:send_after(Time, self(), timeout_pipeline), - State#state{timers = #timers{pipeline_timer = Ref}}. - -is_pipeline_capable_server("HTTP/1." ++ N, _) when hd(N) >= $1 -> - true; -is_pipeline_capable_server("HTTP/1.0", - #http_response_h{connection = "keep-alive"}) -> - true; -is_pipeline_capable_server(_,_) -> - false. - -is_keep_alive_connection(Headers, Session) -> - (not ((Session#tcp_session.client_close) or - httpc_response:is_server_closing(Headers))). - -try_to_enable_pipline(State = #state{session = Session, - request = #request{method = Method}, - status_line = {Version, _, _}, - headers = Headers}) -> - case (is_pipeline_capable_server(Version, Headers)) and - (is_keep_alive_connection(Headers, Session)) and - (httpc_request:is_idempotent(Method)) of - true -> - httpc_manager:insert_session(Session), - State#state{status = pipeline}; - false -> - State#state{status = close} - end. - -answer_request(Request, Msg, State = #state{timers = Timers}) -> - httpc_response:send(Request#request.from, Msg), - RequestTimers = Timers#timers.request_timers, - TimerRef = - http_util:key1search(RequestTimers, Request#request.id, undefined), - Timer = {Request#request.id, TimerRef}, - cancel_timer(TimerRef, {timeout, Request#request.id}), - State#state{request = Request#request{from = answer_sent}, - timers = - Timers#timers{request_timers = - lists:delete(Timer, RequestTimers)}}. -cancel_timer(undefined, _) -> - ok; -cancel_timer(Timer, TimeoutMsg) -> - erlang:cancel_timer(Timer), - receive - TimeoutMsg -> - ok - after 0 -> - ok - end. - -retry_pipline([], _) -> - ok; - -retry_pipline([Request |PipeLine], State = #state{timers = Timers}) -> - NewState = - case (catch httpc_manager:retry_request(Request)) of - ok -> - RequestTimers = Timers#timers.request_timers, - Timer = {_, TimerRef} = - http_util:key1search(RequestTimers, Request#request.id, - {undefined, undefined}), - cancel_timer(TimerRef, {timeout, Request#request.id}), - State#state{timers = Timers#timers{request_timers = - lists:delete(Timer, - RequestTimers)}}; - Error -> - answer_request(Request#request.from, - httpc_response:error(Request, Error), State) - end, - retry_pipline(PipeLine, NewState). - -%%% Check to see if the given {Host,Port} tuple is in the NoProxyList -%%% Returns an eventually updated {Host,Port} tuple, with the proxy address -handle_proxy(HostPort = {Host, _Port}, {Proxy, NoProxy}) -> - case Proxy of - undefined -> - HostPort; - Proxy -> - case is_no_proxy_dest(Host, NoProxy) of - true -> - HostPort; - false -> - Proxy - end - end. - -is_no_proxy_dest(_, []) -> - false; -is_no_proxy_dest(Host, [ "*." ++ NoProxyDomain | NoProxyDests]) -> - - case is_no_proxy_dest_domain(Host, NoProxyDomain) of - true -> - true; - false -> - is_no_proxy_dest(Host, NoProxyDests) - end; - -is_no_proxy_dest(Host, [NoProxyDest | NoProxyDests]) -> - IsNoProxyDest = case http_util:is_hostname(NoProxyDest) of - true -> - fun is_no_proxy_host_name/2; - false -> - fun is_no_proxy_dest_address/2 - end, - - case IsNoProxyDest(Host, NoProxyDest) of - true -> - true; - false -> - is_no_proxy_dest(Host, NoProxyDests) - end. - -is_no_proxy_host_name(Host, Host) -> - true; -is_no_proxy_host_name(_,_) -> - false. - -is_no_proxy_dest_domain(Dest, DomainPart) -> - lists:suffix(DomainPart, Dest). - -is_no_proxy_dest_address(Dest, Dest) -> - true; -is_no_proxy_dest_address(Dest, AddressPart) -> - lists:prefix(AddressPart, Dest). - -socket_type(#request{scheme = http}) -> - ip_comm; -socket_type(#request{scheme = https, settings = Settings}) -> - {ssl, Settings#http_options.ssl}; -socket_type(http) -> - ip_comm; -socket_type(https) -> - {ssl, []}. %% Dummy value ok for ex setops that does not use this value - -start_stream(_, #request{stream = none}) -> - ok; -start_stream({{_, 200, _}, Headers}, Request = #request{stream = self}) -> - Msg = httpc_response:stream_start(Headers, Request), - httpc_response:send(Request#request.from, Msg); -start_stream(_, _) -> - ok. - -%% Note the end stream message is handled by httpc_response and will -%% be sent by answer_request -end_stream(_, #request{stream = none}) -> - ok; -end_stream(_, #request{stream = self}) -> - ok; -end_stream({_,200,_}, #request{stream = Fd}) -> - case file:close(Fd) of - ok -> - ok; - {error, enospc} -> % Could be due to delayed_write - file:close(Fd) - end; -end_stream(_, _) -> - ok. - -handle_verbose(verbose) -> - dbg:p(self(), [r]); -handle_verbose(debug) -> - dbg:p(self(), [call]), - dbg:tp(?MODULE, [{'_', [], [{return_trace}]}]); -handle_verbose(trace) -> - dbg:p(self(), [call]), - dbg:tpl(?MODULE, [{'_', [], [{return_trace}]}]); -handle_verbose(_) -> - ok. - -%%% Normaly I do not comment out code, I throw it away. But this might -%%% actually be used on day if ssl is improved. -%% send_ssl_tunnel_request(Address, Request = #request{address = {Host, Port}}, -%% State) -> -%% %% A ssl tunnel request is a special http request that looks like -%% %% CONNECT host:port HTTP/1.1 -%% SslTunnelRequest = #request{method = connect, scheme = http, -%% headers = -%% #http_request_h{ -%% host = Host, -%% address = Address, -%% path = Host ++ ":", -%% pquery = integer_to_list(Port), -%% other = [{ "Proxy-Connection", "keep-alive"}]}, -%% Ipv6 = (State#state.options)#options.ipv6, -%% SocketType = socket_type(SslTunnelRequest), -%% case http_transport:connect(SocketType, -%% SslTunnelRequest#request.address, Ipv6) of -%% {ok, Socket} -> -%% case httpc_request:send(Address, SslTunnelRequest, Socket) of -%% ok -> -%% Session = #tcp_session{id = -%% {SslTunnelRequest#request.address, -%% self()}, -%% scheme = -%% SslTunnelRequest#request.scheme, -%% socket = Socket}, -%% NewState = State#state{mfa = -%% {httpc_response, parse, -%% [State#state.max_header_size]}, -%% request = Request, -%% session = Session}, -%% http_transport:setopts(socket_type( -%% SslTunnelRequest#request.scheme), -%% Socket, -%% [{active, once}]), -%% {ok, NewState}; -%% {error, Reason} -> -%% self() ! {init_error, error_sending, -%% httpc_response:error(Request, Reason)}, -%% {ok, State#state{request = Request, -%% session = #tcp_session{socket = -%% Socket}}} -%% end; -%% {error, Reason} -> -%% self() ! {init_error, error_connecting, -%% httpc_response:error(Request, Reason)}, -%% {ok, State#state{request = Request}} -%% end. diff --git a/src/couch_inets/httpc_internal.hrl b/src/couch_inets/httpc_internal.hrl deleted file mode 100644 index 86a33cd3..00000000 --- a/src/couch_inets/httpc_internal.hrl +++ /dev/null @@ -1,87 +0,0 @@ -%% ``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$ -%% - --define(HTTP_REQUEST_TIMEOUT, infinity). --define(HTTP_PIPELINE_TIMEOUT, 0). --define(HTTP_PIPELINE_LENGTH, 2). --define(HTTP_MAX_TCP_SESSIONS, 2). --define(HTTP_MAX_REDIRECTS, 4). - -%%% HTTP Client per request settings --record(http_options,{ - %% Milliseconds before a request times out - timeout = ?HTTP_REQUEST_TIMEOUT, - %% bool() - True if automatic redirection on 30X responses. - autoredirect = true, - ssl = [], % Ssl socket options - proxy_auth, % {User, Password} = {strring(), string()} - relaxed = false % bool() true if not strictly standard compliant - }). - -%%% HTTP Client per profile setting. Currently there is only one profile. --record(options, { - proxy = {undefined, []}, % {{ProxyHost, ProxyPort}, [NoProxy]}, - pipeline_timeout = ?HTTP_PIPELINE_TIMEOUT, - max_pipeline_length = ?HTTP_PIPELINE_LENGTH, - max_sessions = ?HTTP_MAX_TCP_SESSIONS, - cookies = disabled, % enabled | disabled | verify - ipv6 = enabled, % enabled | disabled - verbose = false - }). - -%%% All data associated to a specific HTTP request --record(request,{ - id, % ref() - Request Id - from, % pid() - Caller - redircount = 0,% Number of redirects made for this request - scheme, % http | https - address, % ({Host,Port}) Destination Host and Port - path, % string() - Path of parsed URL - pquery, % string() - Rest of parsed URL - method, % atom() - HTTP request Method - headers, % #http_request_h{} - content, % {ContentType, Body} - Current HTTP request - settings, % #http_options{} - User defined settings - abs_uri, % string() ex: "http://www.erlang.org" - userinfo, % string() - optinal "<userinfo>@<host>:<port>" - stream, % Boolean() - stream async reply? - headers_as_is % Boolean() - workaround for servers that does - %% not honor the http standard, can also be used for testing purposes. - }). - --record(tcp_session,{ - id, % {{Host, Port}, HandlerPid} - client_close, % true | false - scheme, % http (HTTP/TCP) | https (HTTP/SSL/TCP) - socket, % Open socket, used by connection - pipeline_length = 1 % Current length of pipeline - }). - --record(http_cookie,{ - domain, - domain_default = false, - name, - value, - comment, - max_age = session, - path, - path_default = false, - secure = false, - version = "0" - }). - diff --git a/src/couch_inets/httpc_manager.erl b/src/couch_inets/httpc_manager.erl deleted file mode 100644 index cf55827b..00000000 --- a/src/couch_inets/httpc_manager.erl +++ /dev/null @@ -1,475 +0,0 @@ -% ``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$ - --module(httpc_manager). - --behaviour(gen_server). - --include("httpc_internal.hrl"). --include("http_internal.hrl"). - -%% Application API --export([start_link/1, request/1, cancel_request/1, - request_canceled/1, retry_request/1, redirect_request/1, - insert_session/1, delete_session/1, set_options/1, store_cookies/2, - cookies/1]). - -%% gen_server callbacks --export([init/1, handle_call/3, handle_cast/2, handle_info/2, terminate/2, - code_change/3]). - --record(state, { - cancel = [], % [{RequestId, HandlerPid, ClientPid}] - handler_db, % ets() - Entry: {Requestid, HandlerPid, ClientPid} - cookie_db, % {ets(), dets()} - {session_cookie_db, cookie_db} - options = #options{} - }). - -%%==================================================================== -%% Application API -%%==================================================================== -%%-------------------------------------------------------------------- -%% Function: start_link() -> {ok, Pid} -%% -%% Description: Starts the http request manger process. (Started by -%% the intes supervisor.) -%%-------------------------------------------------------------------- -start_link({default, CookieDir}) -> - gen_server:start_link({local, ?MODULE}, ?MODULE, - [{http_default_cookie_db, CookieDir}], []). - -%%-------------------------------------------------------------------- -%% Function: request() -> {ok, Requestid} | {error, Reason} -%% Request = #request{} -%% -%% Description: Sends a request to the httpc manager process. -%%-------------------------------------------------------------------- -request(Request) -> - call({request, Request}, infinity). - -%%-------------------------------------------------------------------- -%% Function: retry_request(Request) -> _ -%% Request = #request{} -%% -%% Description: Resends a request to the httpc manager process, intended -%% to be called by the httpc handler process if it has to terminate with -%% a non empty pipeline. -%%-------------------------------------------------------------------- -retry_request(Request) -> - cast({retry_or_redirect_request, Request}). - -%%-------------------------------------------------------------------- -%% Function: redirect_request(Request) -> _ -%% Request = #request{} -%% -%% Description: Sends an atoumatic redirect request to the httpc -%% manager process, intended to be called by the httpc handler process -%% when the automatic redirect option is set. -%%-------------------------------------------------------------------- -redirect_request(Request) -> - cast({retry_or_redirect_request, Request}). - -%%-------------------------------------------------------------------- -%% Function: cancel_request(RequestId) -> ok -%% RequestId - ref() -%% -%% Description: Cancels the request with <RequestId>. -%%-------------------------------------------------------------------- -cancel_request(RequestId) -> - call({cancel_request, RequestId}, infinity). - -%%-------------------------------------------------------------------- -%% Function: request_canceled(RequestId) -> ok -%% RequestId - ref() -%% -%% Description: Confirms that a request has been canceld. Intended to -%% be called by the httpc handler process. -%%-------------------------------------------------------------------- -request_canceled(RequestId) -> - cast({request_canceled, RequestId}). - -%%-------------------------------------------------------------------- -%% Function: insert_session(Session) -> _ -%% Session - #tcp_session{} -%% -%% Description: Inserts session information into the httpc manager table -%% httpc_manager_session_db. Intended to be called by the httpc request -%% handler process. -%%-------------------------------------------------------------------- -insert_session(Session) -> - ets:insert(httpc_manager_session_db, Session). - -%%-------------------------------------------------------------------- -%% Function: delete_session(SessionId) -> _ -%% SessionId - {{Host, Port}, HandlerPid} -%% -%% Description: Deletes session information from the httpc manager table -%% httpc_manager_session_db. Intended to be called by the httpc request -%% handler process. -%%-------------------------------------------------------------------- -delete_session(SessionId) -> - ets:delete(httpc_manager_session_db, SessionId). - -%%-------------------------------------------------------------------- -%% Function: set_options(Options) -> ok -%% -%% Options = [Option] -%% Option = {proxy, {Proxy, [NoProxy]}} | {max_pipeline_length, integer()} | -%% {max_sessions, integer()} | {pipeline_timeout, integer()} -%% Proxy = {Host, Port} -%% NoProxy - [Domain | HostName | IPAddress] -%% Max - integer() -%% -%% Description: Sets the options to be used by the client. -%%-------------------------------------------------------------------- -set_options(Options) -> - cast({set_options, Options}). - -%%-------------------------------------------------------------------- -%% Function: store_cookies(Cookies, Address) -> ok -%% -%% Cookies = [Cookie] -%% Cookie = #http_cookie{} -%% -%% Description: Stores cookies from the server. -%%-------------------------------------------------------------------- -store_cookies([], _) -> - ok; -store_cookies(Cookies, Address) -> - cast({store_cookies, {Cookies, Address}}). - -%%-------------------------------------------------------------------- -%% Function: cookies(Url) -> ok -%% -%% Url = string() -%% -%% Description: Retrieves the cookies that -%%-------------------------------------------------------------------- -cookies(Url) -> - call({cookies, Url}, infinity). - -%%==================================================================== -%% gen_server callback functions -%%==================================================================== - -%%-------------------------------------------------------------------- -%% Function: init([Request, Session]) -> {ok, State} | -%% {ok, State, Timeout} | ignore |{stop, Reason} -%% Description: Initiates the httpc_manger process -%%-------------------------------------------------------------------- -init([CookiesConf|_Options]) -> - process_flag(trap_exit, true), - ets:new(httpc_manager_session_db, - [public, set, named_table, {keypos, #tcp_session.id}]), - {ok, #state{handler_db = ets:new(handler_db, [protected, set]), - cookie_db = - http_cookie:open_cookie_db({CookiesConf, - http_session_cookie_db}) - }}. - -%%-------------------------------------------------------------------- -%% Function: handle_call(Request, From, State) -> {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) -%% Description: Handling call messages -%%-------------------------------------------------------------------- -handle_call({request, Request}, _, State) -> - case (catch handle_request(Request, State)) of - {reply, Msg, NewState} -> - {reply, Msg, NewState}; - Error -> - {stop, Error, httpc_response:error(Request, Error), State} - end; - -handle_call({cancel_request, RequestId}, From, State) -> - case ets:lookup(State#state.handler_db, RequestId) of - [] -> - ok, %% Nothing to cancel - {reply, ok, State}; - [{_, Pid, _}] -> - httpc_handler:cancel(RequestId, Pid), - {noreply, State#state{cancel = - [{RequestId, Pid, From} | - State#state.cancel]}} - end; - -handle_call({cookies, Url}, _, State) -> - case http_uri:parse(Url) of - {Scheme, _, Host, Port, Path, _} -> - CookieHeaders = - http_cookie:header(Scheme, {Host, Port}, - Path, State#state.cookie_db), - {reply, CookieHeaders, State}; - Msg -> - {reply, Msg, State} - end; - -handle_call(Msg, From, State) -> - error_logger:error_report("HTTPC_MANAGER recived unkown call: ~p" - "from: ~p~n", [Msg, From]), - {reply, {error, 'API_violation'}, State}. - -%%-------------------------------------------------------------------- -%% Function: handle_cast(Msg, State) -> {noreply, State} | -%% {noreply, State, Timeout} | -%% {stop, Reason, State} (terminate/2 is called) -%% Description: Handling cast messages -%%-------------------------------------------------------------------- -handle_cast({retry_or_redirect_request, {Time, Request}}, State) -> - {ok, _} = timer:apply_after(Time, ?MODULE, retry_request, [Request]), - {noreply, State}; - -handle_cast({retry_or_redirect_request, Request}, State) -> - case (catch handle_request(Request, State)) of - {reply, {ok, _}, NewState} -> - {noreply, NewState}; - Error -> - httpc_response:error(Request, Error), - {stop, Error, State} - end; - -handle_cast({request_canceled, RequestId}, State) -> - ets:delete(State#state.handler_db, RequestId), - case lists:keysearch(RequestId, 1, State#state.cancel) of - {value, Entry = {RequestId, _, From}} -> - gen_server:reply(From, ok), - {noreply, - State#state{cancel = lists:delete(Entry, State#state.cancel)}}; - _ -> - {noreply, State} - end; -handle_cast({set_options, Options}, State = #state{options = OldOptions}) -> - NewOptions = - #options{proxy = - http_util:key1search(Options, proxy, - OldOptions#options.proxy), - pipeline_timeout = - http_util:key1search(Options, pipeline_timeout, - OldOptions#options.pipeline_timeout), - max_pipeline_length = - http_util:key1search(Options, max_pipeline_length, - OldOptions#options.max_pipeline_length), - max_sessions = - http_util:key1search(Options, max_sessions, - OldOptions#options.max_sessions), - cookies = http_util:key1search(Options, cookies, - OldOptions#options.cookies), - ipv6 = http_util:key1search(Options, ipv6, - OldOptions#options.ipv6), - verbose = http_util:key1search(Options, verbose, - OldOptions#options.verbose) - }, - case {OldOptions#options.verbose, NewOptions#options.verbose} of - {Same, Same} -> - ok; - {_, false} -> - dbg:stop(); - {false, Level} -> - dbg:tracer(), - handle_verbose(Level); - {_, Level} -> - dbg:stop(), - dbg:tracer(), - handle_verbose(Level) - end, - - {noreply, State#state{options = NewOptions}}; - -handle_cast({store_cookies, _}, - State = #state{options = #options{cookies = disabled}}) -> - {noreply, State}; - -handle_cast({store_cookies, {Cookies, _}}, State) -> - ok = do_store_cookies(Cookies, State), - {noreply, State}; - -handle_cast(Msg, State) -> - error_logger:error_report("HTTPC_MANAGER recived unkown cast: ~p", [Msg]), - {noreply, State}. - -%%-------------------------------------------------------------------- -%% Function: handle_info(Info, State) -> {noreply, State} | -%% {noreply, State, Timeout} | -%% {stop, Reason, State} (terminate/2 is called) -%% Description: Handling all non call/cast messages -%%--------------------------------------------------------- -handle_info({'EXIT', _, _}, State) -> - %% Handled in DOWN - {noreply, State}; -handle_info({'DOWN', _, _, Pid, _}, State) -> - ets:match_delete(State#state.handler_db, {'_', Pid, '_'}), - - %% If there where any canceled request, handled by the - %% the process that now has terminated, the - %% cancelation can be viewed as sucessfull! - NewCanceldList = - lists:foldl(fun(Entry = {_, HandlerPid, From}, Acc) -> - case HandlerPid of - Pid -> - gen_server:reply(From, ok), - lists:delete(Entry, Acc); - _ -> - Acc - end - end, State#state.cancel, State#state.cancel), - {noreply, State#state{cancel = NewCanceldList}}; -handle_info(Info, State) -> - error_logger:error_report("Unknown message in " - "httpc_manager:handle_info ~p~n", [Info]), - {noreply, State}. -%%-------------------------------------------------------------------- -%% Function: terminate(Reason, State) -> _ (ignored by gen_server) -%% Description: Shutdown the httpc_handler -%%-------------------------------------------------------------------- -terminate(_, State) -> - http_cookie:close_cookie_db(State#state.cookie_db), - ets:delete(httpc_manager_session_db), - ets:delete(State#state.handler_db). - -%%-------------------------------------------------------------------- -%% Func: code_change(_OldVsn, State, Extra) -> {ok, NewState} -%% Purpose: Convert process state when code is changed -%%-------------------------------------------------------------------- -code_change(_OldVsn, State, _Extra) -> - {ok, State}. - -%%-------------------------------------------------------------------- -%% Internal functions -%%-------------------------------------------------------------------- -handle_request(Request, State) -> - NewRequest = handle_cookies(generate_request_id(Request), State), - case select_session(Request#request.method, - Request#request.address, - Request#request.scheme, State) of - {ok, HandlerPid} -> - pipeline(NewRequest, HandlerPid, State); - no_connection -> - start_handler(NewRequest, State); - {no_session, OpenSessions} when OpenSessions - < State#options.max_sessions -> - start_handler(NewRequest, State); - {no_session, _} -> - %% Do not start any more persistent connections - %% towards this server. - NewHeaders = - (NewRequest#request.headers)#http_request_h{connection - = "close"}, - start_handler(NewRequest#request{headers = NewHeaders}, State) - end, - {reply, {ok, NewRequest#request.id}, State}. - -select_session(Method, HostPort, Scheme, #state{options = - #options{max_pipeline_length = - Max}}) -> - case httpc_request:is_idempotent(Method) of - true -> - Candidates = ets:match(httpc_manager_session_db, - {'_', {HostPort, '$1'}, - false, Scheme, '_', '$2'}), - select_session(Candidates, Max); - false -> - no_connection - end. - -select_session(Candidates, MaxPipeline) -> - case Candidates of - [] -> - no_connection; - _ -> - NewCandidates = - lists:foldl( - fun([Pid, PipelineLength], Acc) when - PipelineLength =< MaxPipeline -> - [{Pid, PipelineLength} | Acc]; - (_, Acc) -> - Acc - end, [], Candidates), - - case lists:keysort(2, NewCandidates) of - [] -> - {no_session, length(Candidates)}; - [{HandlerPid, _} | _] -> - {ok, HandlerPid} - end - end. - -pipeline(Request, HandlerPid, State) -> - case (catch httpc_handler:send(Request, HandlerPid)) of - ok -> - ets:insert(State#state.handler_db, {Request#request.id, - HandlerPid, - Request#request.from}); - _ -> %timeout pipelining failed - start_handler(Request, State) - end. - -start_handler(Request, State) -> - {ok, Pid} = httpc_handler:start_link(Request, State#state.options), - ets:insert(State#state.handler_db, {Request#request.id, - Pid, Request#request.from}), - erlang:monitor(process, Pid). - -generate_request_id(Request) -> - case Request#request.id of - undefined -> - RequestId = make_ref(), - Request#request{id = RequestId}; - _ -> - %% This is an automatic redirect or a retryed pipelined - %% request keep the old id. - Request - end. - -handle_cookies(Request, #state{options = #options{cookies = disabled}}) -> - Request; -handle_cookies(Request = #request{scheme = Scheme, address = Address, - path = Path, headers = - Headers = #http_request_h{other = Other}}, - #state{cookie_db = Db}) -> - case http_cookie:header(Scheme, Address, Path, Db) of - {"cookie", ""} -> - Request; - CookieHeader -> - NewHeaders = - Headers#http_request_h{other = [CookieHeader | Other]}, - Request#request{headers = NewHeaders} - end. - -do_store_cookies([], _) -> - ok; -do_store_cookies([Cookie | Cookies], State) -> - ok = http_cookie:insert(Cookie, State#state.cookie_db), - do_store_cookies(Cookies, State). - -call(Msg, Timeout) -> - gen_server:call(?MODULE, Msg, Timeout). - -cast(Msg) -> - gen_server:cast(?MODULE, Msg). - -handle_verbose(debug) -> - dbg:p(self(), [call]), - dbg:tp(?MODULE, [{'_', [], [{return_trace}]}]); -handle_verbose(trace) -> - dbg:p(self(), [call]), - dbg:tpl(?MODULE, [{'_', [], [{return_trace}]}]); -handle_verbose(_) -> - ok. - diff --git a/src/couch_inets/httpc_request.erl b/src/couch_inets/httpc_request.erl deleted file mode 100644 index 1c74dc7b..00000000 --- a/src/couch_inets/httpc_request.erl +++ /dev/null @@ -1,193 +0,0 @@ -%% ``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$ - --module(httpc_request). - --include("http_internal.hrl"). --include("httpc_internal.hrl"). - -%% We will not make the change to use base64 in stdlib in inets just yet. -%% it will be included in the next major release of inets. --compile({nowarn_deprecated_function, {http_base_64, encode, 1}}). - -%%% Internal API --export([send/3, is_idempotent/1, is_client_closing/1]). - -%%%========================================================================= -%%% Internal application API -%%%========================================================================= -%%------------------------------------------------------------------------- -%% send(MaybeProxy, Request) -> -%% MaybeProxy - {Host, Port} -%% Host = string() -%% Port = integer() -%% Request - #request{} -%% Socket - socket() -%% CookieSupport - enabled | disabled | verify -%% -%% Description: Composes and sends a HTTP-request. -%%------------------------------------------------------------------------- -send(SendAddr, #request{method = Method, scheme = Scheme, - path = Path, pquery = Query, headers = Headers, - content = Content, address = Address, - abs_uri = AbsUri, headers_as_is = HeadersAsIs, - settings = HttpOptions, - userinfo = UserInfo}, - Socket) -> - - TmpHeaders = handle_user_info(UserInfo, Headers), - - {TmpHeaders2, Body} = post_data(Method, TmpHeaders, Content, HeadersAsIs), - - {NewHeaders, Uri} = case Address of - SendAddr -> - {TmpHeaders2, Path ++ Query}; - _Proxy -> - TmpHeaders3 = - handle_proxy(HttpOptions, TmpHeaders2), - {TmpHeaders3, AbsUri} - end, - - FinalHeaders = case NewHeaders of - HeaderList when is_list(HeaderList) -> - headers(HeaderList, []); - _ -> - http_request:http_headers(NewHeaders) - end, - - Message = - lists:append([method(Method), " ", Uri, " HTTP/1.1", ?CRLF, - FinalHeaders, ?CRLF, Body]), - - http_transport:send(socket_type(Scheme), Socket, Message). - -%%------------------------------------------------------------------------- -%% is_idempotent(Method) -> -%% Method = atom() -%% -%% Description: Checks if Methode is considered idempotent. -%%------------------------------------------------------------------------- - -%% In particular, the convention has been established that the GET and -%% HEAD methods SHOULD NOT have the significance of taking an action -%% other than retrieval. These methods ought to be considered "safe". -is_idempotent(head) -> - true; -is_idempotent(get) -> - true; -%% 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. -is_idempotent(put) -> - true; -is_idempotent(delete) -> - true; -%% Also, the methods OPTIONS and TRACE SHOULD NOT have side effects, -%% and so are inherently idempotent. -is_idempotent(trace) -> - true; -is_idempotent(options) -> - true; -is_idempotent(_) -> - false. - -%%------------------------------------------------------------------------- -%% is_client_closing(Headers) -> -%% Headers = #http_request_h{} -%% -%% Description: Checks if the client has supplied a "Connection: close" header. -%%------------------------------------------------------------------------- -is_client_closing(Headers) -> - case Headers#http_request_h.connection of - "close" -> - true; - _ -> - false - end. - -%%%======================================================================== -%%% Internal functions -%%%======================================================================== -post_data(Method, Headers, {ContentType, Body}, HeadersAsIs) - when Method == post; Method == put -> - ContentLength = body_length(Body), - NewBody = case Headers#http_request_h.expect of - "100-continue" -> - ""; - _ -> - Body - end, - - NewHeaders = case HeadersAsIs of - [] -> - Headers#http_request_h{'content-type' = - ContentType, - 'content-length' = - ContentLength}; - _ -> - HeadersAsIs - end, - - {NewHeaders, NewBody}; - -post_data(_, Headers, _, []) -> - {Headers, ""}; -post_data(_, _, _, HeadersAsIs = [_|_]) -> - {HeadersAsIs, ""}. - -body_length(Body) when is_binary(Body) -> - integer_to_list(size(Body)); - -body_length(Body) when is_list(Body) -> - integer_to_list(length(Body)). - -method(Method) -> - http_util:to_upper(atom_to_list(Method)). - -socket_type(http) -> - ip_comm; -socket_type(https) -> - {ssl, []}. - -headers([], Headers) -> - lists:flatten(Headers); -headers([{Key,Value} | Rest], Headers) -> - Header = Key ++ ": " ++ Value ++ ?CRLF, - headers(Rest, [Header | Headers]). - -handle_proxy(_, Headers) when is_list(Headers) -> - Headers; %% Headers as is option was specified -handle_proxy(HttpOptions, Headers) -> - case HttpOptions#http_options.proxy_auth of - undefined -> - Headers; - {User, Password} -> - UserPasswd = http_base_64:encode(User ++ ":" ++ Password), - Headers#http_request_h{'proxy-authorization' = - "Basic " ++ UserPasswd} - end. - -handle_user_info([], Headers) -> - Headers; -handle_user_info(UserInfo, Headers) -> - case string:tokens(UserInfo, ":") of - [User, Passwd] -> - UserPasswd = http_base_64:encode(User ++ ":" ++ Passwd), - Headers#http_request_h{authorization = "Basic " ++ UserPasswd}; - _ -> - Headers - end. diff --git a/src/couch_inets/httpc_response.erl b/src/couch_inets/httpc_response.erl deleted file mode 100644 index 5b6244b6..00000000 --- a/src/couch_inets/httpc_response.erl +++ /dev/null @@ -1,320 +0,0 @@ -%% ``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$ - --module(httpc_response). - --include("http_internal.hrl"). --include("httpc_internal.hrl"). - -%% API --export([parse/1, result/2, send/2, error/2, is_server_closing/1, - stream_start/2]). - -%% Callback API - used for example if the header/body is received a -%% little at a time on a socket. --export([parse_version/1, parse_status_code/1, parse_reason_phrase/1, - parse_headers/1, whole_body/1, whole_body/2]). - -%%%========================================================================= -%%% API -%%%========================================================================= - -parse([Bin, MaxHeaderSize]) -> - parse_version(Bin, [], MaxHeaderSize, []). - -whole_body([Bin, Body, Length]) -> - whole_body(<<Body/binary, Bin/binary>>, Length). - -%% Functions that may be returned during the decoding process -%% if the input data is incompleate. -parse_version([Bin, Version, MaxHeaderSize, Result]) -> - parse_version(Bin, Version, MaxHeaderSize, Result). - -parse_status_code([Bin, Code, MaxHeaderSize, Result]) -> - parse_status_code(Bin, Code, MaxHeaderSize, Result). - -parse_reason_phrase([Bin, Rest, Phrase, MaxHeaderSize, Result]) -> - parse_reason_phrase(<<Rest/binary, Bin/binary>>, Phrase, - MaxHeaderSize, Result). - -parse_headers([Bin, Rest,Header, Headers, MaxHeaderSize, Result]) -> - parse_headers(<<Rest/binary, Bin/binary>>, Header, Headers, - MaxHeaderSize, Result). - -whole_body(Body, Length) -> - case size(Body) of - N when N < Length, N > 0 -> - {?MODULE, whole_body, [Body, Length]}; - %% OBS! The Server may close the connection to indicate that the - %% whole body is now sent instead of sending a lengh - %% indicator.In this case the lengh indicator will be - %% -1. - N when N >= Length, Length >= 0 -> - %% Potential trailing garbage will be thrown away in - %% format_response/1 Some servers may send a 100-continue - %% response without the client requesting it through an - %% expect header in this case the trailing bytes may be - %% part of the real response message. - {ok, Body}; - _ -> %% Length == -1 - {?MODULE, whole_body, [Body, Length]} - end. - -%%------------------------------------------------------------------------- -%% result(Response, Request) -> -%% Response - {StatusLine, Headers, Body} -%% Request - #request{} -%% Session - #tcp_session{} -%% -%% Description: Checks the status code ... -%%------------------------------------------------------------------------- -result(Response = {{_,200,_}, _, _}, - Request = #request{stream = Stream}) when Stream =/= none -> - stream_end(Response, Request); - -result(Response = {{_,100,_}, _, _}, Request) -> - status_continue(Response, Request); - -%% In redirect loop -result(Response = {{_, Code, _}, _, _}, Request = - #request{redircount = Redirects, - settings = #http_options{autoredirect = true}}) - when Code div 100 == 3, Redirects > ?HTTP_MAX_REDIRECTS -> - transparent(Response, Request); - -%% multiple choices -result(Response = {{_, 300, _}, _, _}, - Request = #request{settings = - #http_options{autoredirect = - true}}) -> - redirect(Response, Request); - -result(Response = {{_, Code, _}, _, _}, - Request = #request{settings = - #http_options{autoredirect = true}, - method = head}) when Code == 301; - Code == 302; - Code == 303; - Code == 307 -> - redirect(Response, Request); -result(Response = {{_, Code, _}, _, _}, - Request = #request{settings = - #http_options{autoredirect = true}, - method = get}) when Code == 301; - Code == 302; - Code == 303; - Code == 307 -> - redirect(Response, Request); - - -result(Response = {{_,503,_}, _, _}, Request) -> - status_service_unavailable(Response, Request); -result(Response = {{_,Code,_}, _, _}, Request) when (Code div 100) == 5 -> - status_server_error_50x(Response, Request); - -result(Response, Request) -> - transparent(Response, Request). - -send(To, Msg) -> - To ! {http, Msg}. - -%%%======================================================================== -%%% Internal functions -%%%======================================================================== -parse_version(<<>>, Version, MaxHeaderSize, Result) -> - {?MODULE, parse_version, [Version, MaxHeaderSize,Result]}; -parse_version(<<?SP, Rest/binary>>, Version, MaxHeaderSize, Result) -> - parse_status_code(Rest, [], MaxHeaderSize, - [lists:reverse(Version) | Result]); -parse_version(<<Octet, Rest/binary>>, Version, MaxHeaderSize, Result) -> - parse_version(Rest, [Octet | Version], MaxHeaderSize,Result). - -parse_status_code(<<>>, StatusCodeStr, MaxHeaderSize, Result) -> - {?MODULE, parse_status_code, [StatusCodeStr, MaxHeaderSize, Result]}; -parse_status_code(<<?SP, Rest/binary>>, StatusCodeStr, - MaxHeaderSize, Result) -> - parse_reason_phrase(Rest, [], MaxHeaderSize, - [list_to_integer(lists:reverse(StatusCodeStr)) | - Result]); -parse_status_code(<<Octet, Rest/binary>>, StatusCodeStr, - MaxHeaderSize,Result) -> - parse_status_code(Rest, [Octet | StatusCodeStr], MaxHeaderSize, Result). - -parse_reason_phrase(<<>>, Phrase, MaxHeaderSize, Result) -> - {?MODULE, parse_reason_phrase, [<<>>, Phrase, MaxHeaderSize,Result]}; -parse_reason_phrase(<<?CR, ?LF, Rest/binary>>, Phrase, - MaxHeaderSize, Result) -> - parse_headers(Rest, [], [], MaxHeaderSize, - [lists:reverse(Phrase) | Result]); -parse_reason_phrase(<<?CR>> = Data, Phrase, MaxHeaderSize, Result) -> - {?MODULE, parse_reason_phrase, [Data, Phrase, MaxHeaderSize,Result]}; -parse_reason_phrase(<<Octet, Rest/binary>>, Phrase, MaxHeaderSize, Result) -> - parse_reason_phrase(Rest, [Octet | Phrase], MaxHeaderSize, Result). - -parse_headers(<<>>, Header, Headers, MaxHeaderSize, Result) -> - {?MODULE, parse_headers, [<<>>, Header, Headers, MaxHeaderSize, Result]}; -parse_headers(<<?CR,?LF,?CR,?LF,Body/binary>>, Header, Headers, - MaxHeaderSize, Result) -> - HTTPHeaders = [lists:reverse(Header) | Headers], - Length = lists:foldl(fun(H, Acc) -> length(H) + Acc end, - 0, HTTPHeaders), - case ((Length =< MaxHeaderSize) or (MaxHeaderSize == nolimit)) of - true -> - ResponseHeaderRcord = - http_response:headers(HTTPHeaders, #http_response_h{}), - {ok, list_to_tuple( - lists:reverse([Body, ResponseHeaderRcord | Result]))}; - false -> - throw({error, {header_too_long, MaxHeaderSize, - MaxHeaderSize-Length}}) - end; -parse_headers(<<?CR,?LF,?CR>> = Data, Header, Headers, - MaxHeaderSize, Result) -> - {?MODULE, parse_headers, [Data, Header, Headers, MaxHeaderSize, Result]}; -parse_headers(<<?CR,?LF>> = Data, Header, Headers, - MaxHeaderSize, Result) -> - {?MODULE, parse_headers, [Data, Header, Headers, MaxHeaderSize, Result]}; -parse_headers(<<?CR,?LF, Octet, Rest/binary>>, Header, Headers, - MaxHeaderSize, Result) -> - parse_headers(Rest, [Octet], - [lists:reverse(Header) | Headers], MaxHeaderSize, Result); -parse_headers(<<?CR>> = Data, Header, Headers, - MaxHeaderSize, Result) -> - {?MODULE, parse_headers, [Data, Header, Headers, MaxHeaderSize, Result]}; -parse_headers(<<Octet, Rest/binary>>, Header, Headers, - MaxHeaderSize, Result) -> - parse_headers(Rest, [Octet | Header], Headers, MaxHeaderSize, Result). - - -%% RFC2616, Section 10.1.1 -%% Note: -%% - Only act on the 100 status if the request included the -%% "Expect:100-continue" header, otherwise just ignore this response. -status_continue(_, #request{headers = - #http_request_h{expect = "100-continue"}}) -> - continue; - -status_continue({_,_, Data}, _) -> - %% The data in the body in this case is actually part of the real - %% response sent after the "fake" 100-continue. - {ignore, Data}. - -status_service_unavailable(Response = {_, Headers, _}, Request) -> - case Headers#http_response_h.'retry-after' of - undefined -> - status_server_error_50x(Response, Request); - Time when length(Time) < 3 -> % Wait only 99 s or less - NewTime = list_to_integer(Time) * 100, % time in ms - {_, Data} = format_response(Response), - {retry, {NewTime, Request}, Data}; - _ -> - status_server_error_50x(Response, Request) - end. - -status_server_error_50x(Response, Request) -> - {Msg, _} = format_response(Response), - {stop, {Request#request.id, Msg}}. - - -redirect(Response = {StatusLine, Headers, Body}, Request) -> - {_, Data} = format_response(Response), - case Headers#http_response_h.location of - undefined -> - transparent(Response, Request); - RedirUrl -> - case http_uri:parse(RedirUrl) of - {error, no_scheme} when - (Request#request.settings)#http_options.relaxed -> - NewLocation = fix_relative_uri(Request, RedirUrl), - redirect({StatusLine, Headers#http_response_h{ - location = NewLocation}, - Body}, Request); - {error, Reason} -> - {ok, error(Request, Reason), Data}; - %% Automatic redirection - {Scheme, _, Host, Port, Path, Query} -> - NewHeaders = - (Request#request.headers)#http_request_h{host = - Host}, - NewRequest = - Request#request{redircount = - Request#request.redircount+1, - scheme = Scheme, - headers = NewHeaders, - address = {Host,Port}, - path = Path, - pquery = Query, - abs_uri = - atom_to_list(Scheme) ++ "://" ++ - Host ++ ":" ++ - integer_to_list(Port) ++ - Path ++ Query}, - {redirect, NewRequest, Data} - end - end. - -%%% Guessing that we received a relative URI, fix it to become an absoluteURI -fix_relative_uri(Request, RedirUrl) -> - {Server, Port} = Request#request.address, - Path = Request#request.path, - atom_to_list(Request#request.scheme) ++ "://" ++ Server ++ ":" ++ Port - ++ Path ++ RedirUrl. - -error(#request{id = Id}, Reason) -> - {Id, {error, Reason}}. - -transparent(Response, Request) -> - {Msg, Data} = format_response(Response), - {ok, {Request#request.id, Msg}, Data}. - -stream_start(Headers, Request) -> - {Request#request.id, stream_start, http_response:header_list(Headers)}. - -stream_end(Response, Request = #request{stream = self}) -> - {{_, Headers, _}, Data} = format_response(Response), - {ok, {Request#request.id, stream_end, Headers}, Data}; -stream_end(Response, Request) -> - {_, Data} = format_response(Response), - {ok, {Request#request.id, saved_to_file}, Data}. - -is_server_closing(Headers) when record(Headers,http_response_h) -> - case Headers#http_response_h.connection of - "close" -> - true; - _ -> - false - end. - -format_response({StatusLine, Headers, Body = <<>>}) -> - {{StatusLine, http_response:header_list(Headers), Body}, <<>>}; - -format_response({StatusLine, Headers, Body}) -> - Length = list_to_integer(Headers#http_response_h.'content-length'), - {NewBody, Data} = - case Length of - 0 -> - {Body, <<>>}; - -1 -> % When no lenght indicator is provided - {Body, <<>>}; - Length when Length =< size(Body) -> - <<BodyThisReq:Length/binary, Next/binary>> = Body, - {BodyThisReq, Next}; - _ -> %% Connection prematurely ended. - {Body, <<>>} - end, - {{StatusLine, http_response:header_list(Headers), NewBody}, Data}. - diff --git a/src/couch_inets/httpc_sup.erl b/src/couch_inets/httpc_sup.erl deleted file mode 100644 index 5583c6c8..00000000 --- a/src/couch_inets/httpc_sup.erl +++ /dev/null @@ -1,70 +0,0 @@ -%% ``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$ -%% --module(httpc_sup). - --behaviour(supervisor). - -%% API --export([start_link/1]). - -%% Supervisor callback --export([init/1]). - -%%%========================================================================= -%%% API -%%%========================================================================= -start_link(HttpcServices) -> - supervisor:start_link({local, ?MODULE}, ?MODULE, [HttpcServices]). - -%%%========================================================================= -%%% Supervisor callback -%%%========================================================================= -init([]) -> - init([[]]); -init([HttpcServices]) -> - RestartStrategy = one_for_one, - MaxR = 10, - MaxT = 3600, - Children = child_spec(HttpcServices, []), - {ok, {{RestartStrategy, MaxR, MaxT}, Children}}. - -child_spec([], []) -> - [httpc_child_spec(default, only_session_cookies)]; -child_spec([], Acc) -> - Acc; -child_spec([{httpc, {Profile, Dir}} | Rest], Acc) -> - case httpc_child_spec(Profile, Dir) of - {} -> - child_spec(Rest, Acc); - Spec -> - child_spec(Rest, [Spec | Acc]) - end. - -%% Note currently only one profile is supported e.i. the default profile -httpc_child_spec(default, Dir) -> - Name = httpc_manager, - StartFunc = {httpc_manager, start_link, [{default, Dir}]}, - Restart = permanent, - Shutdown = 4000, - Modules = [httpc_manager], - Type = worker, - {Name, StartFunc, Restart, Shutdown, Type, Modules}; -httpc_child_spec(_,_) -> - {}. - - diff --git a/src/couch_inets/httpd.erl b/src/couch_inets/httpd.erl deleted file mode 100644 index 830753c4..00000000 --- a/src/couch_inets/httpd.erl +++ /dev/null @@ -1,516 +0,0 @@ -%% ``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$ -%% --module(httpd). - --export([multi_start/1, multi_start_link/1, - start/0, start/1, - start_link/0, start_link/1, - 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, start_link2/1, 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([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"). - -start() -> - start("/var/tmp/server_root/conf/5984.conf"). - -start(ConfigFile) -> - httpd_instance_sup:start(ConfigFile). - -start_link() -> - start("/var/tmp/server_root/conf/5984.conf"). - -start_link(ConfigFile) when is_list(ConfigFile) -> - httpd_instance_sup:start_link(ConfigFile). - -start2(Config) when is_list(Config) -> - httpd_instance_sup:start2(Config). - -start_link2(Config) -> - httpd_instance_sup:start_link2(Config). - -stop() -> - stop(5984). - -stop(Port) when is_integer(Port) -> - stop(undefined, Port); -stop(Pid) when is_pid(Pid) -> - httpd_instance_sup:stop(Pid); -stop(ConfigFile) when is_list(ConfigFile) -> - httpd_instance_sup:stop(ConfigFile). - -stop(Addr, Port) when is_integer(Port) -> - httpd_instance_sup:stop(Addr, Port). - -stop2(Config) when is_list(Config) -> - httpd_instance_sup:stop2(Config). - -start_child() -> - start_child("/var/tmp/server_root/conf/5984.conf"). - -start_child(ConfigFile) -> - httpd_sup:start_child(ConfigFile). - -stop_child() -> - stop_child(5984). - -stop_child(Port) -> - stop_child(undefined, Port). - -stop_child(Addr, Port) when integer(Port) -> - httpd_sup:stop_child(Addr, Port). - -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(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(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(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(undefined,5984). - -restart(Port) when is_integer(Port) -> - restart(undefined,Port); -restart(ConfigFile) when is_list(ConfigFile) -> - case get_addr_and_port(ConfigFile) of - {ok,Addr,Port} -> - restart(Addr,Port); - Error -> - Error - end. - -restart(Addr,Port) when is_integer(Port) -> - do_restart(Addr,Port). - -do_restart(Addr,Port) when is_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,5984,disturbing). - -block(Port) when is_integer(Port) -> - block(undefined,Port,disturbing); - -block(ConfigFile) when is_list(ConfigFile) -> - case get_addr_and_port(ConfigFile) of - {ok,Addr,Port} -> - block(Addr,Port,disturbing); - Error -> - Error - end. - -block(Addr,Port) when is_integer(Port) -> - block(Addr,Port,disturbing); - -block(Port,Mode) when is_integer(Port), is_atom(Mode) -> - block(undefined,Port,Mode); - -block(ConfigFile,Mode) when is_list(ConfigFile), is_atom(Mode) -> - case get_addr_and_port(ConfigFile) of - {ok,Addr,Port} -> - block(Addr,Port,Mode); - Error -> - Error - end. - - -block(Addr,Port,disturbing) when is_integer(Port) -> - do_block(Addr,Port,disturbing); -block(Addr,Port,non_disturbing) when is_integer(Port) -> - do_block(Addr,Port,non_disturbing); - -block(ConfigFile,Mode,Timeout) when is_list(ConfigFile), is_atom(Mode), - is_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 - is_integer(Port), is_integer(Timeout) -> - do_block(Addr,Port,non_disturbing,Timeout); -block(Addr,Port,disturbing,Timeout) when is_integer(Port), - is_integer(Timeout) -> - do_block(Addr,Port,disturbing,Timeout). - -do_block(Addr,Port,Mode) when is_integer(Port), is_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 is_integer(Port), is_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,5984). -unblock(Port) when is_integer(Port) -> unblock(undefined,Port); - -unblock(ConfigFile) when is_list(ConfigFile) -> - case get_addr_and_port(ConfigFile) of - {ok,Addr,Port} -> - unblock(Addr,Port); - Error -> - Error - end. - -unblock(Addr,Port) when is_integer(Port) -> - Name = make_name(Addr,Port), - case whereis(Name) of - Pid when pid(Pid) -> - httpd_manager:unblock(Pid); - _ -> - {error,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,5984). -get_admin_state(Port) when is_integer(Port) -> get_admin_state(undefined,Port); - -get_admin_state(ConfigFile) when is_list(ConfigFile) -> - case get_addr_and_port(ConfigFile) of - {ok,Addr,Port} -> - unblock(Addr,Port); - Error -> - Error - end. - -get_admin_state(Addr,Port) when is_integer(Port) -> - Name = make_name(Addr,Port), - case whereis(Name) of - Pid when is_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,5984). -get_usage_state(Port) when is_integer(Port) -> get_usage_state(undefined,Port); - -get_usage_state(ConfigFile) when is_list(ConfigFile) -> - case get_addr_and_port(ConfigFile) of - {ok,Addr,Port} -> - unblock(Addr,Port); - Error -> - Error - end. - -get_usage_state(Addr,Port) when is_integer(Port) -> - Name = make_name(Addr,Port), - case whereis(Name) of - Pid when is_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 is_list(ConfigFile) -> - case get_addr_and_port(ConfigFile) of - {ok,Addr,Port} -> - get_status(Addr,Port); - Error -> - Error - end; - -get_status(Port) when is_integer(Port) -> - get_status(undefined,Port,5000). - -get_status(Port,Timeout) when is_integer(Port), is_integer(Timeout) -> - get_status(undefined,Port,Timeout); - -get_status(Addr,Port) when is_list(Addr), is_integer(Port) -> - get_status(Addr,Port,5000). - -get_status(Addr,Port,Timeout) when is_integer(Port) -> - Name = make_name(Addr,Port), - case whereis(Name) of - Pid when is_pid(Pid) -> - httpd_manager:get_status(Pid,Timeout); - _ -> - not_started - end. - -load(ConfigFile) -> - httpd_conf:load(ConfigFile). - -load_mime_types(MimeTypesFile) -> - httpd_conf:load_mime_types(MimeTypesFile). - -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(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(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([$# | _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/src/couch_inets/httpd.hrl b/src/couch_inets/httpd.hrl deleted file mode 100644 index f9c74926..00000000 --- a/src/couch_inets/httpd.hrl +++ /dev/null @@ -1,78 +0,0 @@ -%% ``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$ -%% - --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(GATEWAY_INTERFACE,"CGI/1.1"). --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/src/couch_inets/httpd_acceptor.erl b/src/couch_inets/httpd_acceptor.erl deleted file mode 100644 index 9138912f..00000000 --- a/src/couch_inets/httpd_acceptor.erl +++ /dev/null @@ -1,155 +0,0 @@ -%% ``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$ -%% --module(httpd_acceptor). - --include("httpd.hrl"). - -%% External API --export([start_link/5, start_link/6]). - -%% Other exports (for spawn's etc.) --export([acceptor/5, acceptor/6, acceptor/7]). - - -%% -%% External API -%% - -%% start_link - -start_link(Manager, SocketType, Addr, Port, ConfigDb) -> - start_link(Manager, SocketType, Addr, Port, ConfigDb, 15000). - -start_link(Manager, SocketType, Addr, Port, ConfigDb,AcceptTimeout) -> - Args = [self(), Manager, SocketType, Addr, Port, ConfigDb, AcceptTimeout], - proc_lib:start_link(?MODULE, acceptor, Args). - -acceptor(Parent, Manager, SocketType, Addr, Port, ConfigDb) -> - acceptor(Parent, Manager, SocketType, Addr, Port, ConfigDb, 15000). -acceptor(Parent, Manager, SocketType, Addr, Port, ConfigDb, AcceptTimeout) -> - case (catch do_init(SocketType, Addr, Port)) of - {ok, ListenSocket} -> - proc_lib:init_ack(Parent, {ok, self()}), - acceptor(Manager, SocketType, ListenSocket, ConfigDb, AcceptTimeout); - 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 http_transport:start(SocketType) of - ok -> - ok; - {error, Reason} -> - throw({error, {socket_start_failed, Reason}}) - end. - - -do_socket_listen(SocketType, Addr, Port) -> - case http_transport:listen(SocketType, Addr, Port) of - {ok, ListenSocket} -> - ListenSocket; - {error, Reason} -> - throw({error, {listen, Reason}}) - end. - - -%% acceptor - -acceptor(Manager, SocketType, ListenSocket, ConfigDb, AcceptTimeout) -> - case (catch http_transport:accept(SocketType, ListenSocket, 50000)) of - {ok, Socket} -> - handle_connection(Manager, ConfigDb, AcceptTimeout, SocketType, Socket), - ?MODULE:acceptor(Manager, SocketType, ListenSocket, ConfigDb,AcceptTimeout); - {error, Reason} -> - handle_error(Reason, ConfigDb, SocketType), - ?MODULE:acceptor(Manager, SocketType, ListenSocket, ConfigDb, AcceptTimeout); - {'EXIT', Reason} -> - handle_error({'EXIT', Reason}, ConfigDb, SocketType), - ?MODULE:acceptor(Manager, SocketType, ListenSocket, ConfigDb, AcceptTimeout) - end. - - -handle_connection(Manager, ConfigDb, AcceptTimeout, SocketType, Socket) -> - {ok, Pid} = httpd_request_handler:start(Manager, ConfigDb, AcceptTimeout), - http_transport:controlling_process(SocketType, Socket, Pid), - httpd_request_handler:socket_ownership_transfered(Pid, SocketType, Socket). - -handle_error(timeout, _, _) -> - ok; - -handle_error({enfile, _}, _, _) -> - %% Out of sockets... - sleep(200); - -handle_error(emfile, _, _) -> - %% Too many open files -> Out of sockets... - sleep(200); - -handle_error(closed, _, _) -> - error_logger:info_report("The httpd accept socket was closed by" - "a third party. " - "This will not have an impact on inets " - "that will open a new accept socket and " - "go on as nothing happened. It does however " - "indicate that some other software is behaving " - "badly."), - exit(normal); - -%% This will only happen when the client is terminated abnormaly -%% and is not a problem for the server, so we want -%% to terminate normal so that we can restart without any -%% error messages. -handle_error(econnreset,_,_) -> - exit(normal); - -handle_error(econnaborted, _, _) -> - 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) -> - String = lists:flatten(io_lib:format("Accept exit: ~p", [Reason])), - accept_failed(SocketType, ConfigDb, String); - -handle_error(Reason, ConfigDb, SocketType) -> - 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}). - -sleep(T) -> receive after T -> ok end. - - diff --git a/src/couch_inets/httpd_acceptor_sup.erl b/src/couch_inets/httpd_acceptor_sup.erl deleted file mode 100644 index a0656e0a..00000000 --- a/src/couch_inets/httpd_acceptor_sup.erl +++ /dev/null @@ -1,84 +0,0 @@ -%% ``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$ -%% -%%---------------------------------------------------------------------- -%% Purpose: The supervisor for acceptor processes in the http server, -%% hangs under the httpd_instance_sup_<Addr>_<Port> supervisor. -%%---------------------------------------------------------------------- - --module(httpd_acceptor_sup). - --behaviour(supervisor). - -%% API --export([start_link/2, start_acceptor/4, start_acceptor/5, stop_acceptor/2]). - -%% Supervisor callback --export([init/1]). - -%%%========================================================================= -%%% API -%%%========================================================================= -start_link(Addr, Port) -> - SupName = make_name(Addr, Port), - supervisor:start_link({local, SupName}, ?MODULE, []). - -%%---------------------------------------------------------------------- -%% Function: [start|stop]_acceptor/5 -%% Description: Starts/stops an [auth | security] worker (child) process -%%---------------------------------------------------------------------- -start_acceptor(SocketType, Addr, Port, ConfigDb) -> - start_acceptor(SocketType, Addr, Port, ConfigDb,15000). -start_acceptor(SocketType, Addr, Port, ConfigDb, AcceptTimeout) -> - start_worker(httpd_acceptor, SocketType, Addr, Port, - ConfigDb, AcceptTimeout, self(), []). - -stop_acceptor(Addr, Port) -> - stop_worker(httpd_acceptor, Addr, Port). - -%%%========================================================================= -%%% Supervisor callback -%%%========================================================================= -init(_) -> - Flags = {one_for_one, 500, 100}, - Workers = [], - {ok, {Flags, Workers}}. - -%%%========================================================================= -%%% Internal functions -%%%========================================================================= - -make_name(Addr,Port) -> - httpd_util:make_name("httpd_acc_sup", Addr, Port). - -start_worker(M, SocketType, Addr, Port, ConfigDB, AcceptTimeout, Manager, Modules) -> - SupName = make_name(Addr, Port), - Args = [Manager, SocketType, Addr, Port, ConfigDB, AcceptTimeout], - Spec = {{M, Addr, Port}, - {M, start_link, Args}, - permanent, timer:seconds(1), worker, [M] ++ Modules}, - supervisor:start_child(SupName, Spec). - -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. diff --git a/src/couch_inets/httpd_cgi.erl b/src/couch_inets/httpd_cgi.erl deleted file mode 100644 index 0e0d7f2b..00000000 --- a/src/couch_inets/httpd_cgi.erl +++ /dev/null @@ -1,122 +0,0 @@ -%% ``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$ -%% --module(httpd_cgi). - --export([parse_headers/1, handle_headers/1]). - --include("inets_internal.hrl"). - -%%%========================================================================= -%%% Internal application API -%%%========================================================================= - -%%-------------------------------------------------------------------------- -%% parse_headers([Bin, Data, Header, Headers]) -> {RevHeaders, Body} | -%% {Module, Function, Args} -%% Bin = Data = binary() -%% Header = string() - Accumulator should be [] in first call -%% Headers = [Header] - Accumulator should be [] in first call -%% Body = string() -%% RevHeaders = string() - Note CGI-headers not HTTP-headers -%% -%% Description: Parses "<<Bin/binary, Data/binary>>" returned from the -%% CGI-script until it findes the end of the CGI-headers (at least one -%% CGI-HeaderField must be supplied) then it returns the CGI-headers -%% and maybe some body data. If {Module, Function, Args} is -%% returned it means that more data needs to be collected from the -%% cgi-script as the end of the headers was not yet found. When more -%% data has been collected call Module:Function([NewData | Args]). -%% -%% NOTE: The headers are backwards and should -%% be so, devide_and_reverse_headers will reverse them back after -%% taking advantage of the fact that they where backwards. -%%-------------------------------------------------------------------------- -parse_headers([Data, Bin, Header, Headers]) -> - parse_headers(<<Bin/binary, Data/binary>>, Header, Headers). - -%%-------------------------------------------------------------------------- -%% handle_headers(CGIHeaders) -> {ok, HTTPHeaders, StatusCode} | -%% {proceed, AbsPath} -%% CGIHeaders = [string()] -%% HTTPHeaders = [{HeaderField, HeaderValue}] -%% HeaderField = string() -%% HeaderValue = string() -%% StatusCode = integer() -%% -%% Description: Interprets CGI headers and creates HTTP headers and a -%% appropriate HTTP status code. Note if a CGI location header is present -%% the return value will be {proceed, AbsPath} -%%-------------------------------------------------------------------------- -handle_headers(CGIHeaders) -> - handle_headers(CGIHeaders, [], {200, "ok"}). - -%%%======================================================================== -%%% Internal functions -%%%======================================================================== -parse_headers(<<>>, Header, Headers) -> - {?MODULE, parse_headers, [<<>>, Header, Headers]}; -parse_headers(<<?CR,?LF>>, Header, Headers) -> - {?MODULE, parse_headers, [<<?CR,?LF>>, Header, Headers]}; -parse_headers(<<?LF>>, Header, Headers) -> - {?MODULE, parse_headers, [<<?LF>>, Header, Headers]}; -parse_headers(<<?CR, ?LF, ?CR, ?LF, Rest/binary>>, Header, Headers) -> - {ok, {[lists:reverse([?LF, ?CR | Header]) | Headers], Rest}}; -parse_headers(<<?LF, ?LF, Rest/binary>>, Header, Headers) -> - {ok, {[lists:reverse([?LF | Header]) | Headers], Rest}}; -parse_headers(<<?CR, ?LF, Rest/binary>>, Header, Headers) -> - parse_headers(Rest, [], [lists:reverse([?LF, ?CR | Header]) | Headers]); -parse_headers(<<?LF, Rest/binary>>, Header, Headers) -> - parse_headers(Rest, [], [lists:reverse([?LF | Header]) | Headers]); -parse_headers(<<Octet, Rest/binary>>, Header, Headers) -> - parse_headers(Rest, [Octet | Header], Headers). - -handle_headers([], HTTPHeaders, Status) -> - {ok, HTTPHeaders, Status}; - -handle_headers([CGIHeader | CGIHeaders], HTTPHeaders, Status) -> - - {FieldName, FieldValue} = httpd_response:split_header(CGIHeader, []), - - case FieldName of - "content-type" -> - handle_headers(CGIHeaders, - [{FieldName, FieldValue} | HTTPHeaders], - Status); - "location" -> - case http_request:is_absolut_uri(FieldValue) of - true -> - handle_headers(CGIHeaders, - [{FieldName, FieldValue} | - HTTPHeaders], {302, "Redirect"}); - false -> - {proceed, FieldValue} - end; - "status" -> - CodePhrase = - case httpd_util:split(FieldValue," ",2) of - {ok,[Code, Phrase]} -> - {list_to_integer(Code), Phrase}; - _ -> - {200, "OK"} - end, - handle_headers(CGIHeaders, HTTPHeaders, CodePhrase); - _ -> %% Extension headers - handle_headers(CGIHeaders, - [{FieldName, FieldValue} | HTTPHeaders], Status) - end. - diff --git a/src/couch_inets/httpd_conf.erl b/src/couch_inets/httpd_conf.erl deleted file mode 100644 index a9dac808..00000000 --- a/src/couch_inets/httpd_conf.erl +++ /dev/null @@ -1,720 +0,0 @@ -%% ``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$ -%% --module(httpd_conf). - -%% EWSAPI --export([is_directory/1, is_file/1, make_integer/1, clean/1, - custom_clean/3, check_enum/2]). - -%% Application internal API --export([load/1, load/2, load_mime_types/1, store/1, store/2, - remove/1, remove_all/1, config/1]). - --define(VMODULE,"CONF"). --include("httpd.hrl"). - -%%%========================================================================= -%%% EWSAPI -%%%========================================================================= -%%------------------------------------------------------------------------- -%% is_directory(FilePath) -> Result -%% FilePath = string() -%% Result = {ok,Directory} | {error,Reason} -%% Directory = string() -%% Reason = string() | enoent | eaccess | enotdir | FileInfo -%% FileInfo = File info record -%% -%% Description: Checks if FilePath is a directory in which case it is -%% returned. -%%------------------------------------------------------------------------- -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(FilePath) -> Result -%% FilePath = string() -%% Result = {ok,File} | {error,Reason} -%% File = string() -%% Reason = string() | enoent | eaccess | enotdir | FileInfo -%% FileInfo = File info record -%% -%% Description: Checks if FilePath is a regular file in which case it -%% is returned. -%%------------------------------------------------------------------------- -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(String) -> Result -%% String = string() -%% Result = {ok,integer()} | {error,nomatch} -%% -%% Description: make_integer/1 returns an integer representation of String. -%%------------------------------------------------------------------------- -make_integer(String) -> - case regexp:match(clean(String),"[0-9]+") of - {match, _, _} -> - {ok, list_to_integer(clean(String))}; - nomatch -> - {error, nomatch} - end. -%%------------------------------------------------------------------------- -%% clean(String) -> Stripped -%% String = Stripped = string() -%% -%% Description:clean/1 removes leading and/or trailing white spaces -%% from String. -%%------------------------------------------------------------------------- -clean(String) -> - {ok,CleanedString,_} = - regexp:gsub(String, "^[ \t\n\r\f]*|[ \t\n\r\f]*\$",""), - CleanedString. -%%------------------------------------------------------------------------- -%% custom_clean(String,Before,After) -> Stripped -%% Before = After = regexp() -%% String = Stripped = string() -%% -%% Description: custom_clean/3 removes leading and/or trailing white -%% spaces and custom characters from String. -%%------------------------------------------------------------------------- -custom_clean(String,MoreBefore,MoreAfter) -> - {ok,CleanedString,_} = regexp:gsub(String,"^[ \t\n\r\f"++MoreBefore++ - "]*|[ \t\n\r\f"++MoreAfter++"]*\$",""), - CleanedString. -%%------------------------------------------------------------------------- -%% check_enum(EnumString,ValidEnumStrings) -> Result -%% EnumString = string() -%% ValidEnumStrings = [string()] -%% Result = {ok,atom()} | {error,not_valid} -%% -%% Description: check_enum/2 checks if EnumString is a valid -%% enumeration of ValidEnumStrings in which case it is returned as an -%% atom. -%%------------------------------------------------------------------------- -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). - -%%%========================================================================= -%%% Application internal API -%%%========================================================================= -%% 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). - -%% Phase 1: Load -load(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. - -load(eof, []) -> - eof; -load("MaxHeaderSize " ++ 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("MaxHeaderAction " ++ Action, []) -> - {ok, [], {max_header_action,list_to_atom(clean(Action))}}; -load("MaxBodySize " ++ 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("MaxBodyAction " ++ Action, []) -> - {ok, [], {max_body_action,list_to_atom(clean(Action))}}; -load("ServerName " ++ ServerName, []) -> - {ok,[],{server_name,clean(ServerName)}}; -load("SocketType " ++ 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("Port " ++ Port, []) -> - case make_integer(Port) of - {ok, Integer} -> - {ok, [], {port,Integer}}; - {error, _} -> - {error, ?NICE(clean(Port)++" is an invalid Port")} - end; -load("BindAddress " ++ Address, []) -> - %% If an ipv6 address is provided in URL-syntax strip the - %% url specific part e.i. "[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]" - %% -> "FEDC:BA98:7654:3210:FEDC:BA98:7654:3210" - NewAddress = string:strip(string:strip(clean(Address), - left, $[), - right, $]), - case NewAddress of - "*" -> - {ok, [], {bind_address,any}}; - CAddress -> - case (catch inet:getaddr(CAddress,inet6)) of - {ok, {0, 0, 0, 0, 0, 16#ffff, _, _}} -> - case inet:getaddr(CAddress, inet) of - {ok, IPAddr} -> - {ok, [], {bind_address,IPAddr}}; - {error, _} -> - {error, ?NICE(CAddress++" is an invalid address")} - end; - {ok, IPAddr} -> - {ok, [], {bind_address, IPAddr}}; - _ -> - case inet:getaddr(CAddress, inet) of - {ok, IPAddr} -> - {ok, [], {bind_address,IPAddr}}; - {error, _} -> - {error, ?NICE(CAddress++" is an invalid address")} - end - end - end; -load("KeepAlive " ++ OnorOff, []) -> - case list_to_atom(clean(OnorOff)) of - off -> - {ok, [], {persistent_conn, false}}; - _ -> - {ok, [], {persistent_conn, true}} - end; -load("MaxKeepAliveRequests " ++ MaxRequests, []) -> - case make_integer(MaxRequests) of - {ok, Integer} -> - {ok, [], {max_keep_alive_request, Integer}}; - {error, _} -> - {error, ?NICE(clean(MaxRequests) ++ - " is an invalid MaxKeepAliveRequests")} - end; -%% This clause is keept for backwards compability -load("MaxKeepAliveRequest " ++ 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("KeepAliveTimeout " ++ 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("Modules " ++ Modules, []) -> - {ok, ModuleList} = regexp:split(Modules," "), - {ok, [], {modules,[list_to_atom(X) || X <- ModuleList]}}; -load("ServerAdmin " ++ ServerAdmin, []) -> - {ok, [], {server_admin,clean(ServerAdmin)}}; -load("ServerRoot " ++ 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("MaxClients " ++ 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("DocumentRoot " ++ 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("DefaultType " ++ DefaultType, []) -> - {ok, [], {default_type,clean(DefaultType)}}; -load("SSLCertificateFile " ++ 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("SSLCertificateKeyFile " ++ 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("SSLVerifyClient " ++ 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("SSLVerifyDepth " ++ 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("SSLCiphers " ++ SSLCiphers, []) -> - {ok, [], {ssl_ciphers, clean(SSLCiphers)}}; -load("SSLCACertificateFile " ++ 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("SSLPasswordCallbackModule " ++ SSLPasswordCallbackModule, []) -> - {ok, [], {ssl_password_callback_module, - list_to_atom(clean(SSLPasswordCallbackModule))}}; -load("SSLPasswordCallbackFunction " ++ SSLPasswordCallbackFunction, []) -> - {ok, [], {ssl_password_callback_function, - list_to_atom(clean(SSLPasswordCallbackFunction))}}; -load("DisableChunkedTransferEncodingSend " ++ TrueOrFalse, []) -> - case list_to_atom(clean(TrueOrFalse)) of - true -> - {ok, [], {disable_chunked_transfer_encoding_send, true}}; - _ -> - {ok, [], {disable_chunked_transfer_encoding_send, false}} - end. - -%% -%% 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. - -%% Phase 2: 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), - ConfigDB = ets:new(Name, [named_table, bag, protected]), - store(ConfigDB, ConfigList, lists:append(Modules,[?MODULE]),ConfigList). - -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), - {ok, MimeTypesDB} = store_mime_types(Name,MimeTypesList), - {ok, {mime_types,MimeTypesDB}}; -store(ConfigListEntry, _ConfigList) -> - {ok, ConfigListEntry}. - -%% Phase 3: Remove -remove_all(ConfigDB) -> - Modules = httpd_util:lookup(ConfigDB,modules,[]), - remove_traverse(ConfigDB, lists:append(Modules,[?MODULE])). - -remove(ConfigDB) -> - ets:delete(ConfigDB), - ok. - -config(ConfigDB) -> - case httpd_util:lookup(ConfigDB,com_type,ip_comm) of - ssl -> - case ssl_certificate_file(ConfigDB) of - undefined -> - {error, - "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. - -%%%======================================================================== -%%% Internal functions -%%%======================================================================== -%%% Phase 1 Load: -bootstrap([]) -> - {error, ?NICE("Modules must be specified in the config file")}; -bootstrap([Line|Config]) -> - case Line of - "Modules " ++ Modules -> - {ok, ModuleList} = regexp:split(Modules," "), - TheMods = [list_to_atom(X) || X <- ModuleList], - case verify_modules(TheMods) of - ok -> - {ok, TheMods}; - {error, Reason} -> - {error, Reason} - end; - _ -> - bootstrap(Config) - end. - -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) -> - case load_traverse(Line, Contexts, Modules, [], ConfigList, no) of - {ok, NewContexts, NewConfigList} -> - load_config(Config, Modules, NewContexts, NewConfigList); - {error, Reason} -> - {error, Reason} - end. - - -%% 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_traverse(Line, [], [], _NewContexts, _ConfigList, no) -> - {error, ?NICE("Configuration directive not recognized: "++Line)}; -load_traverse(_Line, [], [], NewContexts, ConfigList, yes) -> - {ok, lists:reverse(NewContexts), ConfigList}; -load_traverse(Line, [Context|Contexts], [Module|Modules], NewContexts, - ConfigList, State) -> - case catch apply(Module, load, [Line, Context]) of - {'EXIT', {function_clause, _}} -> - load_traverse(Line, Contexts, Modules, - [Context|NewContexts], ConfigList, State); - {'EXIT',{undef, _}} -> - load_traverse(Line, Contexts, Modules, - [Context|NewContexts], ConfigList,yes); - {'EXIT', Reason} -> - error_logger:error_report({'EXIT', Reason}), - load_traverse(Line, Contexts, Modules, - [Context|NewContexts], ConfigList, State); - {ok, NewContext} -> - load_traverse(Line, Contexts, Modules, - [NewContext|NewContexts], ConfigList,yes); - {ok, NewContext, ConfigEntry} when tuple(ConfigEntry) -> - load_traverse(Line, Contexts, Modules, [NewContext|NewContexts], - [ConfigEntry|ConfigList], yes); - {ok, NewContext, ConfigEntry} when list(ConfigEntry) -> - load_traverse(Line, Contexts, Modules, [NewContext|NewContexts], - lists:append(ConfigEntry, ConfigList), yes); - {error, Reason} -> - {error, Reason} - end. - -%% 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. - -%% 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 -> - file:close(Stream), - {ok, lists:reverse(SoFar)}; - {error, Reason} -> - file:close(Stream), - {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. - -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)]. - -a_must(_ConfigList,[]) -> - ok; -a_must(ConfigList,[Directive|Rest]) -> - case httpd_util:key1search(ConfigList,Directive) of - undefined -> - {missing,Directive}; - _ -> - a_must(ConfigList,Rest) - end. - -%% Pahse 2: store -store(ConfigDB, _ConfigList, _Modules,[]) -> - {ok, ConfigDB}; -store(ConfigDB, ConfigList, Modules, [ConfigListEntry|Rest]) -> - case store_traverse(ConfigListEntry,ConfigList,Modules) of - {ok, ConfigDBEntry} when tuple(ConfigDBEntry) -> - ets:insert(ConfigDB,ConfigDBEntry), - store(ConfigDB,ConfigList,Modules,Rest); - {ok, ConfigDBEntry} when list(ConfigDBEntry) -> - lists:foreach(fun(Entry) -> - ets:insert(ConfigDB,Entry) - end,ConfigDBEntry), - store(ConfigDB,ConfigList,Modules,Rest); - {error, Reason} -> - {error,Reason} - end. - -store_traverse(_ConfigListEntry, _ConfigList,[]) -> - {error,?NICE("Unable to store configuration...")}; -store_traverse(ConfigListEntry, ConfigList, [Module|Rest]) -> - case catch apply(Module,store,[ConfigListEntry, ConfigList]) of - {'EXIT',{function_clause,_}} -> - store_traverse(ConfigListEntry,ConfigList,Rest); - {'EXIT',{undef, _}} -> - store_traverse(ConfigListEntry,ConfigList,Rest); - {'EXIT', Reason} -> - error_logger:error_report({'EXIT',Reason}), - store_traverse(ConfigListEntry,ConfigList,Rest); - Result -> - Result - end. - -store_mime_types(Name,MimeTypesList) -> - %% Make sure that the ets table is not duplicated - %% when reloading configuration - catch ets:delete(Name), - MimeTypesDB = ets:new(Name, [named_table, set, protected]), - store_mime_types1(MimeTypesDB, MimeTypesList). -store_mime_types1(MimeTypesDB,[]) -> - {ok, MimeTypesDB}; -store_mime_types1(MimeTypesDB,[Type|Rest]) -> - ets:insert(MimeTypesDB, Type), - store_mime_types1(MimeTypesDB, Rest). - - -%% Phase 3: remove -remove_traverse(_ConfigDB,[]) -> - ok; -remove_traverse(ConfigDB,[Module|Rest]) -> - case (catch apply(Module,remove,[ConfigDB])) of - {'EXIT',{undef,_}} -> - remove_traverse(ConfigDB,Rest); - {'EXIT',{function_clause,_}} -> - remove_traverse(ConfigDB,Rest); - {'EXIT',Reason} -> - error_logger:error_report({'EXIT',Reason}), - remove_traverse(ConfigDB,Rest); - {error,Reason} -> - error_logger:error_report(Reason), - remove_traverse(ConfigDB,Rest); - _ -> - remove_traverse(ConfigDB,Rest) - 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/src/couch_inets/httpd_esi.erl b/src/couch_inets/httpd_esi.erl deleted file mode 100644 index 2f7c9d38..00000000 --- a/src/couch_inets/httpd_esi.erl +++ /dev/null @@ -1,106 +0,0 @@ -%% ``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$ -%% --module(httpd_esi). - --export([parse_headers/1, handle_headers/1]). - --include("inets_internal.hrl"). - -%%%========================================================================= -%%% Internal application API -%%%========================================================================= - -%%-------------------------------------------------------------------------- -%% parse_headers(Data) -> {Headers, Body} -%% -%% Data = string() | io_list() -%% Headers = string() -%% Body = io_list() -%% -%% Description: Parses <Data> and divides it to a header part and a -%% body part. Note that it is presumed that <Data> starts with a -%% string including "\r\n\r\n" if there is any header information -%% present. The returned headers will not contain the HTTP header body -%% delimiter \r\n. (All header, header delimiters are keept.) -%% Ex: ["Content-Type : text/html\r\n Connection : closing \r\n\r\n" | -%% io_list()] --> {"Content-Type : text/html\r\n Connection : closing \r\n", -%% io_list()} -%%-------------------------------------------------------------------------- -parse_headers(Data) -> - parse_headers(Data, []). - -%%-------------------------------------------------------------------------- -%% handle_headers(Headers) -> {ok, HTTPHeaders, StatusCode} | -%% {proceed, AbsPath} -%% Headers = string() -%% HTTPHeaders = [{HeaderField, HeaderValue}] -%% HeaderField = string() -%% HeaderValue = string() -%% StatusCode = integer() -%% -%% Description: Transforms the plain HTTP header string data received -%% from the ESI program into a list of header values and an -%% appropriate HTTP status code. Note if a location header is present -%% the return value will be {proceed, AbsPath} -%%-------------------------------------------------------------------------- -handle_headers("") -> - {ok, [], 200}; -handle_headers(Headers) -> - NewHeaders = string:tokens(Headers, ?CRLF), - handle_headers(NewHeaders, [], 200). - -%%%======================================================================== -%%% Internal functions -%%%======================================================================== -parse_headers([], Acc) -> - {[], lists:reverse(Acc)}; -parse_headers([?CR, ?LF, ?CR, ?LF], Acc) -> - {lists:reverse(Acc) ++ [?CR, ?LF], []}; -parse_headers([?CR, ?LF, ?CR, ?LF | Rest], Acc) -> - {lists:reverse(Acc) ++ [?CR, ?LF], Rest}; -parse_headers([Char | Rest], Acc) -> - parse_headers(Rest, [Char | Acc]). - -handle_headers([], NewHeaders, StatusCode) -> - {ok, NewHeaders, StatusCode}; - -handle_headers([Header | Headers], NewHeaders, StatusCode) -> - {FieldName, FieldValue} = httpd_response:split_header(Header, []), - case FieldName of - "location" -> - case http_request:is_absolut_uri(FieldValue) of - true -> - handle_headers(Headers, - [{FieldName, FieldValue} | NewHeaders], - 302); - false -> - {proceed, FieldValue} - end; - "status" -> - NewStatusCode = - case httpd_util:split(FieldValue," ",2) of - {ok,[Code,_]} -> - list_to_integer(Code); - _ -> - 200 - end, - handle_headers(Headers, NewHeaders, NewStatusCode); - _ -> - handle_headers(Headers, - [{FieldName, FieldValue}| NewHeaders], StatusCode) - end. diff --git a/src/couch_inets/httpd_example.erl b/src/couch_inets/httpd_example.erl deleted file mode 100644 index 66c6ca39..00000000 --- a/src/couch_inets/httpd_example.erl +++ /dev/null @@ -1,143 +0,0 @@ -%% ``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$ -%% --module(httpd_example). --export([print/1]). --export([get/2, post/2, yahoo/2, test1/2, get_bin/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). - -get_bin(_Env,_Input) -> - [list_to_binary(header()), - list_to_binary(top("GET Example")), - list_to_binary("<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()]. - -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/src/couch_inets/httpd_instance_sup.erl b/src/couch_inets/httpd_instance_sup.erl deleted file mode 100644 index ddf81a49..00000000 --- a/src/couch_inets/httpd_instance_sup.erl +++ /dev/null @@ -1,193 +0,0 @@ -%% ``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$ -%% -%%---------------------------------------------------------------------- -%% Purpose: The top supervisor for an instance of the http server. (You may -%% have several instances running on the same machine.) Hangs under -%% httpd_sup. -%%---------------------------------------------------------------------- - --module(httpd_instance_sup). - --behaviour(supervisor). - --export([init/1]). - -%% Internal API --export([start/1, start_link/1, start_link/3, start2/1, start_link2/1, - stop/1, stop/2, stop2/1]). - -%%%========================================================================= -%%% Supervisor callback -%%%========================================================================= -init([ConfigFile, ConfigList, AcceptTimeout, Debug, Addr, Port]) -> - httpd_util:enable_debug(Debug), - Flags = {one_for_one, 0, 1}, - Children = [sup_spec(httpd_acceptor_sup, Addr, Port), - sup_spec(httpd_misc_sup, Addr, Port), - worker_spec(httpd_manager, Addr, Port, - ConfigFile, ConfigList,AcceptTimeout)], - {ok, {Flags, Children}}. - - -%%%========================================================================= -%%% ??? functions -%%%========================================================================= - -start(ConfigFile) -> - case start_link(ConfigFile) of - {ok, Pid} -> - unlink(Pid), - {ok, Pid}; - - Else -> - Else - end. - -start_link(Config) -> - case catch httpd_options(Config) of - {error,Reason} -> - error_logger:error_report(Reason), - {stop, Reason}; - {ConfigFile,AcceptTimeout,Debug} -> - start_link(ConfigFile, AcceptTimeout, Debug) - end. -start_link(ConfigFile, AcceptTimeout, Debug) -> - 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 ,AcceptTimeout , - Debug, Addr, Port]); - {error, Reason} -> - error_logger:error_report(Reason), - {stop, Reason} - end. - - -start2(ConfigList) -> - case start_link2(ConfigList) of - {ok, Pid} -> - unlink(Pid), - {ok, Pid}; - - Else -> - Else - end. - - -start_link2(ConfigList) -> - {ok, Addr, Port} = get_addr_and_port2(ConfigList), - Name = make_name(Addr, Port), - SupName = {local, Name}, - Debug = [], - AcceptTimeout = 15000, - supervisor:start_link(SupName, ?MODULE, - [undefined, ConfigList, AcceptTimeout, - Debug, Addr, Port]). - - -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). - -%%%========================================================================= -%%% Internal functions -%%%========================================================================= -do_stop(Pid) -> - exit(Pid, shutdown). - -sup_spec(SupModule, Addr, Port) -> - Name = {SupModule, Addr, Port}, - StartFunc = {SupModule, start_link, [Addr, Port]}, - Restart = permanent, - Shutdown = infinity, - Modules = [SupModule], - Type = supervisor, - {Name, StartFunc, Restart, Shutdown, Type, Modules}. - -worker_spec(WorkerModule, Addr, Port, ConfigFile, ConfigList, AcceptTimeout) -> - Name = {WorkerModule, Addr, Port}, - StartFunc = {WorkerModule, start_link, - [ConfigFile, ConfigList, AcceptTimeout]}, - Restart = permanent, - Shutdown = 4000, - Modules = [WorkerModule], - Type = worker, - {Name, StartFunc, Restart, Shutdown, Type, Modules}. - -httpd_options(Config) -> - OptionList = mk_tuple_list(Config), - Debug = http_util:key1search(OptionList,debug,[]), - AcceptTimeout = http_util:key1search(OptionList,accept_timeout,15000), - ConfigFile = - case http_util:key1search(OptionList,file) of - undefined -> throw({error,{mandatory_conf_file_missed}}); - File -> File - end, - httpd_util:valid_options(Debug,AcceptTimeout,ConfigFile), - {ConfigFile, AcceptTimeout, Debug}. - -mk_tuple_list([]) -> - []; -mk_tuple_list([H={_,_}|T]) -> - [H|mk_tuple_list(T)]; -mk_tuple_list(F) when list(F) -> - [{file,F}]. - -make_name(Addr,Port) -> - httpd_util:make_name("httpd_instance_sup",Addr,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}. diff --git a/src/couch_inets/httpd_manager.erl b/src/couch_inets/httpd_manager.erl deleted file mode 100644 index b7529f37..00000000 --- a/src/couch_inets/httpd_manager.erl +++ /dev/null @@ -1,829 +0,0 @@ -%% ``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$ -%% - --module(httpd_manager). - --include("httpd.hrl"). - --behaviour(gen_server). - -%% External API --export([start/2, 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([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) -> - Port = httpd_util:key1search(ConfigList,port,80), - Addr = httpd_util:key1search(ConfigList,bind_address), - Name = make_name(Addr,Port), - gen_server:start({local,Name},?MODULE, - [ConfigFile, ConfigList, 15000, Addr, Port],[]). - -start_link(ConfigFile, ConfigList) -> - start_link(ConfigFile, ConfigList, 15000). -start_link(ConfigFile, ConfigList, AcceptTimeout) -> - Port = httpd_util:key1search(ConfigList,port,80), - Addr = httpd_util:key1search(ConfigList,bind_address), - Name = make_name(Addr,Port), - gen_server:start_link({local, Name},?MODULE, - [ConfigFile, ConfigList, AcceptTimeout, Addr, Port],[]). - -stop(ServerRef) -> - gen_server:call(ServerRef, stop). - -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). - -%% -%% Internal API -%% - - -%% new_connection - -new_connection(Manager) -> - gen_server:call(Manager, {new_connection, self()}, infinity). - -%% 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, AcceptTimeout, Addr, Port]) -> - process_flag(trap_exit, true), - case (catch do_init(ConfigFile, ConfigList, AcceptTimeout, Addr, Port)) of - {error, Reason} -> - String = lists:flatten(io_lib:format("Failed initiating web server: ~n~p~n~p~n",[ConfigFile,Reason])), - error_logger:error_report(String), - {stop, Reason}; - {ok, State} -> - {ok, State} - end. - - -do_init(ConfigFile, ConfigList, AcceptTimeout, Addr, Port) -> - ConfigDB = do_initial_store(ConfigList), - SocketType = httpd_conf:config(ConfigDB), - case httpd_acceptor_sup:start_acceptor(SocketType, Addr, - Port, ConfigDB, AcceptTimeout) of - {ok, _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}, - {ok, State}; - Else -> - Else - end. - - -do_initial_store(ConfigList) -> - case httpd_conf:store(ConfigList) of - {ok, ConfigDB} -> - ConfigDB; - {error, Reason} -> - throw({error, Reason}) - end. - - - -%% handle_call - -handle_call(stop, _From, State) -> - {stop, normal, ok, State}; - -handle_call({config_lookup, Query}, _From, State) -> - Res = httpd_util:lookup(State#state.config_db, Query), - {reply, Res, State}; - -handle_call({config_multi_lookup, Query}, _From, State) -> - Res = httpd_util:multi_lookup(State#state.config_db, Query), - {reply, Res, State}; - -handle_call({config_match, Query}, _From, State) -> - Res = ets:match_object(State#state.config_db, Query), - {reply, Res, State}; - -handle_call(get_status, _From, State) -> - ManagerStatus = manager_status(self()), - S1 = [{current_conn,length(State#state.connections)}|State#state.status]++ - [ManagerStatus], - {reply,S1,State}; - -handle_call(is_busy, _From, State) -> - Reply = case get_ustate(State) of - busy -> - true; - _ -> - false - end, - {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, - {reply,Reply,State}; - -handle_call(is_blocked, _From, State) -> - Reply = - case get_astate(State) of - unblocked -> - false; - _ -> - true - end, - {reply,Reply,State}; - -handle_call(get_admin_state, _From, State) -> - Reply = get_astate(State), - {reply,Reply,State}; - -handle_call(get_usage_state, _From, State) -> - Reply = get_ustate(State), - {reply,Reply,State}; - -handle_call(restart, _From, State) when State#state.admin_state == blocked -> - case handle_restart(State) of - {stop, Reply,S1} -> - {stop, Reply, S1}; - {_, Reply, S1} -> - {reply,Reply,S1} - end; - -handle_call(restart, _From, State) -> - {reply,{error,{invalid_admin_state,State#state.admin_state}},State}; - -handle_call(block, _From, State) -> - {Reply,S1} = handle_block(State), - {reply,Reply,S1}; - -handle_call(unblock, {From,_Tag}, State) -> - {Reply,S1} = handle_unblock(State,From), - {reply, Reply, S1}; - -handle_call({new_connection, Pid}, _From, State) -> - {Status, NewState} = handle_new_connection(State, Pid), - {reply, Status, NewState}; - -handle_call(Request, From, State) -> - 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) -> - S1 = handle_done_connection(State, Pid), - {noreply, S1}; - -handle_cast({block, disturbing, Timeout, From, Ref}, State) -> - S1 = handle_block(State, Timeout, From, Ref), - {noreply,S1}; - -handle_cast({block, non_disturbing, Timeout, From, Ref}, State) -> - S1 = handle_nd_block(State, Timeout, From, Ref), - {noreply,S1}; - -handle_cast(Message, State) -> - 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) -> - S1 = handle_block_timeout(State,Method), - {noreply, S1}; - -handle_info({'DOWN', Ref, process, _Object, _Info}, State) -> - S1 = - case State#state.blocker_ref of - Ref -> - handle_blocker_exit(State); - _ -> - %% Not our blocker, so ignore - State - end, - {noreply, S1}; - -handle_info({'EXIT', _, normal}, State) -> - {noreply, State}; - -handle_info({'EXIT', _, blocked}, S) -> - {noreply, S}; - -handle_info({'EXIT', Pid, Reason}, State) -> - S1 = check_connections(State, Pid, Reason), - {noreply, S1}; - -handle_info(Info, State) -> - String = - lists:flatten( - io_lib:format("Unknown info " - "~n ~p" - "~nto manager (~p)", - [Info, self()])), - report_error(State, String), - {noreply, State}. - - -%% terminate - -terminate(_, #state{config_db = Db}) -> - 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), - demonitor_blocker(State#state.blocker_ref), - {Tmr,From,Ref} = State#state.blocking_tmr, - stop_block_tmr(Tmr), - 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; - NewConnections -> - String = - lists:flatten( - io_lib:format("request handler (~p) crashed:" - "~n ~p", [Pid, Reason])), - report_error(State, String), - State#state{connections = NewConnections} - 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), - {{ok, 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 - demonitor_blocker(State#state.blocker_ref), - {Tmr,From,Ref} = State#state.blocking_tmr, - stop_block_tmr(Tmr), - 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 - [kill_handler(Pid) || Pid <- S#state.connections], - {ok,S#state{connections = [], admin_state = blocked}}; -handle_block(S,blocked) -> - {ok,S}; -handle_block(S,shutting_down) -> - {{error,shutting_down},S}. - - -kill_handler(Pid) -> - exit(Pid, blocked). - -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 - From ! {block_reply,ok,Ref}, - S#state{admin_state = blocked}; - _ -> - %% Active or Busy usage state => go to shutting_down - %% Make sure we get to know if blocker dies... - MonitorRef = monitor_blocker(From), - 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 - From ! {block_reply,ok,Ref}, - S#state{admin_state = blocked}; - _ -> - %% Active or Busy usage state => go to shutting_down - %% Make sure we get to know if blocker dies... - MonitorRef = monitor_blocker(From), - 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}) -> - From ! {block_reply,{error,timeout},Ref}, - S#state{admin_state = unblocked, - blocker_ref = undefined, blocking_tmr = undefined}; - -handle_block_timeout1(S,disturbing,{_,From,Ref}) -> - [exit(Pid,blocked) || Pid <- S#state.connections], - - From ! {block_reply,ok,Ref}, - S#state{admin_state = blocked, connections = [], - blocker_ref = undefined, blocking_tmr = undefined}; - -handle_block_timeout1(S,Method,{_,From,Ref}) -> - 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) -> - 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) -> - 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, - 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) -> - {ok, Config} = httpd_conf:load(ConfigFile), - case (catch check_constant_values(Db, Config)) of - ok -> - %% If something goes wrong between the remove - %% and the store where fu-ed - httpd_conf:remove_all(Db), - case httpd_conf:store(Config) of - {ok, NewConfigDB} -> - {continue, ok, State#state{config_db = NewConfigDB}}; - Error -> - {stop, Error, State} - end; - Error -> - {continue, Error, State} - end. - - -check_constant_values(Db, Config) -> - %% 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 - 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 - 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, - 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 - {'EXIT', _Reason} -> - undefined; - MonitorRef -> - MonitorRef - 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(). - -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). - -%% -call(ServerRef,Request) -> - gen_server:call(ServerRef,Request). - -cast(ServerRef,Message) -> - gen_server:cast(ServerRef,Message). - diff --git a/src/couch_inets/httpd_misc_sup.erl b/src/couch_inets/httpd_misc_sup.erl deleted file mode 100644 index 35a65344..00000000 --- a/src/couch_inets/httpd_misc_sup.erl +++ /dev/null @@ -1,89 +0,0 @@ -%% ``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$ -%% -%%---------------------------------------------------------------------- -%% Purpose: The supervisor for auth and sec processes in the http server, -%% hangs under the httpd_instance_sup_<Addr>_<Port> supervisor. -%%---------------------------------------------------------------------- - --module(httpd_misc_sup). - --behaviour(supervisor). - -%% API --export([start_link/2, start_auth_server/2, stop_auth_server/2, - start_sec_server/2, stop_sec_server/2]). - -%% Supervisor callback --export([init/1]). - -%%%========================================================================= -%%% API -%%%========================================================================= - -start_link(Addr, Port) -> - SupName = make_name(Addr, Port), - supervisor:start_link({local, SupName}, ?MODULE, []). - -%%---------------------------------------------------------------------- -%% Function: [start|stop]_[auth|sec]_server/3 -%% Description: Starts a [auth | security] worker (child) process -%%---------------------------------------------------------------------- -start_auth_server(Addr, Port) -> - start_permanent_worker(mod_auth_server, Addr, Port, [gen_server]). - -stop_auth_server(Addr, Port) -> - stop_permanent_worker(mod_auth_server, Addr, Port). - - -start_sec_server(Addr, Port) -> - start_permanent_worker(mod_security_server, Addr, Port, [gen_server]). - -stop_sec_server(Addr, Port) -> - stop_permanent_worker(mod_security_server, Addr, Port). - - -%%%========================================================================= -%%% Supervisor callback -%%%========================================================================= -init(_) -> - Flags = {one_for_one, 0, 1}, - Workers = [], - {ok, {Flags, Workers}}. - -%%%========================================================================= -%%% Internal functions -%%%========================================================================= -start_permanent_worker(Mod, Addr, Port, Modules) -> - SupName = make_name(Addr, Port), - Spec = {{Mod, Addr, Port}, - {Mod, start_link, [Addr, Port]}, - permanent, timer:seconds(1), worker, [Mod] ++ Modules}, - supervisor:start_child(SupName, Spec). - -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/src/couch_inets/httpd_request.erl b/src/couch_inets/httpd_request.erl deleted file mode 100644 index bce7e725..00000000 --- a/src/couch_inets/httpd_request.erl +++ /dev/null @@ -1,337 +0,0 @@ -%% ``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$ - --module(httpd_request). - --include("http_internal.hrl"). --include("httpd.hrl"). - --export([parse/1, whole_body/2, validate/3, update_mod_data/5, - body_data/2]). - -%% Callback API - used for example if the header/body is received a -%% little at a time on a socket. --export([parse_method/1, parse_uri/1, parse_version/1, parse_headers/1, - whole_body/1]). - -%%%========================================================================= -%%% Internal application API -%%%========================================================================= -parse([Bin, MaxHeaderSize]) -> - parse_method(Bin, [], MaxHeaderSize, []). - -%% Functions that may be returned during the decoding process -%% if the input data is incompleate. -parse_method([Bin, Method, MaxHeaderSize, Result]) -> - parse_method(Bin, Method, MaxHeaderSize, Result). - -parse_uri([Bin, URI, MaxHeaderSize, Result]) -> - parse_uri(Bin, URI, MaxHeaderSize, Result). - -parse_version([Bin, Rest, Version, MaxHeaderSize, Result]) -> - parse_version(<<Rest/binary, Bin/binary>>, Version, MaxHeaderSize, - Result). - -parse_headers([Bin, Rest, Header, Headers, MaxHeaderSize, Result]) -> - parse_headers(<<Rest/binary, Bin/binary>>, - Header, Headers, MaxHeaderSize, Result). - -whole_body([Bin, Body, Length]) -> - whole_body(<<Body/binary, Bin/binary>>, Length). - - -%% Separate the body for this request from a possible piplined new -%% request and convert the body data to "string" format. -body_data(Headers, Body) -> - ContentLength = list_to_integer(Headers#http_request_h.'content-length'), - case size(Body) - ContentLength of - 0 -> - {binary_to_list(Body), <<>>}; - _ -> - <<BodyThisReq:ContentLength/binary, Next/binary>> = Body, - {binary_to_list(BodyThisReq), Next} - end. - -%%------------------------------------------------------------------------- -%% validate(Method, Uri, Version) -> ok | {error, {bad_request, Reason} | -%% {error, {not_supported, {Method, Uri, Version}} -%% Method = "HEAD" | "GET" | "POST" | "TRACE" -%% Uri = uri() -%% Version = "HTTP/N.M" -%% Description: Checks that HTTP-request-line is valid. -%%------------------------------------------------------------------------- -validate("HEAD", Uri, "HTTP/1." ++ _N) -> - validate_uri(Uri); -validate("GET", Uri, []) -> %% Simple HTTP/0.9 - validate_uri(Uri); -validate("GET", Uri, "HTTP/0.9") -> - validate_uri(Uri); -validate("GET", Uri, "HTTP/1." ++ _N) -> - validate_uri(Uri); -validate("POST", Uri, "HTTP/1." ++ _N) -> - validate_uri(Uri); -validate("TRACE", Uri, "HTTP/1." ++ N) when hd(N) >= $1 -> - validate_uri(Uri); -validate("PUT", Uri, "HTTP/1." ++ _N) -> - validate_uri(Uri); -validate("DELETE", Uri, "HTTP/1." ++ _N) -> - validate_uri(Uri); -validate(Method, Uri, Version) -> - {error, {not_supported, {Method, Uri, Version}}}. - -%%---------------------------------------------------------------------- -%% The request is passed through the server as a record of type mod -%% create it. -%% ---------------------------------------------------------------------- -update_mod_data(ModData, Method, RequestURI, HTTPVersion, Headers)-> - ParsedHeaders = tagup_header(Headers), - PersistentConn = get_persistens(HTTPVersion, ParsedHeaders, - ModData#mod.config_db), - {ok, ModData#mod{data = [], - method = Method, - absolute_uri = format_absolute_uri(RequestURI, - ParsedHeaders), - request_uri = format_request_uri(RequestURI), - http_version = HTTPVersion, - request_line = Method ++ " " ++ RequestURI ++ - " " ++ HTTPVersion, - parsed_header = ParsedHeaders, - connection = PersistentConn}}. - -%%%======================================================================== -%%% Internal functions -%%%======================================================================== -parse_method(<<>>, Method, MaxHeaderSize, Result) -> - {?MODULE, parse_method, [Method, MaxHeaderSize, Result]}; -parse_method(<<?SP, Rest/binary>>, Method, MaxHeaderSize, Result) -> - parse_uri(Rest, [], MaxHeaderSize, - [string:strip(lists:reverse(Method)) | Result]); -parse_method(<<Octet, Rest/binary>>, Method, MaxHeaderSize, Result) -> - parse_method(Rest, [Octet | Method], MaxHeaderSize, Result). - -parse_uri(<<>>, URI, MaxHeaderSize, Result) -> - {?MODULE, parse_uri, [URI, MaxHeaderSize, Result]}; -parse_uri(<<?SP, Rest/binary>>, URI, MaxHeaderSize, Result) -> - parse_version(Rest, [], MaxHeaderSize, - [string:strip(lists:reverse(URI)) | Result]); -%% Can happen if it is a simple HTTP/0.9 request e.i "GET /\r\n\r\n" -parse_uri(<<?CR, _Rest/binary>> = Data, URI, MaxHeaderSize, Result) -> - parse_version(Data, [], MaxHeaderSize, - [string:strip(lists:reverse(URI)) | Result]); -parse_uri(<<Octet, Rest/binary>>, URI, MaxHeaderSize, Result) -> - parse_uri(Rest, [Octet | URI], MaxHeaderSize, Result). - -parse_version(<<>>, Version, MaxHeaderSize, Result) -> - {?MODULE, parse_version, [<<>>, Version, MaxHeaderSize, Result]}; -parse_version(<<?CR, ?LF, Rest/binary>>, Version, MaxHeaderSize, Result) -> - parse_headers(Rest, [], [], MaxHeaderSize, - [string:strip(lists:reverse(Version)) | Result]); -parse_version(<<?CR>> = Data, Version, MaxHeaderSize, Result) -> - {?MODULE, parse_version, [Data, Version, MaxHeaderSize, Result]}; -parse_version(<<Octet, Rest/binary>>, Version, MaxHeaderSize, Result) -> - parse_version(Rest, [Octet | Version], MaxHeaderSize, Result). - -parse_headers(<<>>, Header, Headers, MaxHeaderSize, Result) -> - {?MODULE, parse_headers, [<<>>, Header, Headers, MaxHeaderSize, Result]}; -parse_headers(<<?CR,?LF,?CR,?LF,Body/binary>>, [], [], _, Result) -> - NewResult = list_to_tuple(lists:reverse([Body, {#http_request_h{}, []} | - Result])), - {ok, NewResult}; -parse_headers(<<?CR,?LF,?CR,?LF,Body/binary>>, Header, Headers, - MaxHeaderSize, Result) -> - HTTPHeaders = [lists:reverse(Header) | Headers], - Length = lists:foldl(fun(H, Acc) -> length(H) + Acc end, - 0, HTTPHeaders), - case ((Length > MaxHeaderSize) or (MaxHeaderSize == nolimit)) of - true -> - {error, {header_too_long, MaxHeaderSize}, - lists:nth(3, lists:reverse(Result))}; % HTTP Version - false -> - RequestHeaderRcord = - http_request:headers(HTTPHeaders, #http_request_h{}), - NewResult = - list_to_tuple(lists:reverse([Body, {RequestHeaderRcord, - HTTPHeaders} | Result])), - {ok, NewResult} - end; -parse_headers(<<?CR,?LF,?CR>> = Data, Header, Headers, - MaxHeaderSize, Result) -> - {?MODULE, parse_headers, [Data, Header, Headers, MaxHeaderSize, Result]}; - -%% There where no headers, which is unlikely to happen. -parse_headers(<<?CR,?LF>>, [], [], _, Result) -> - NewResult = list_to_tuple(lists:reverse([<<>>, {#http_request_h{}, []} | - Result])), - {ok, NewResult}; -parse_headers(<<?CR,?LF>> = Data, Header, Headers, - MaxHeaderSize, Result) -> - {?MODULE, parse_headers, [Data, Header, Headers, MaxHeaderSize, Result]}; -parse_headers(<<?CR,?LF, Octet, Rest/binary>>, Header, Headers, - MaxHeaderSize, Result) -> - parse_headers(Rest, [Octet], [lists:reverse(Header) | Headers], - MaxHeaderSize, Result); -parse_headers(<<?CR>> = Data, Header, Headers, - MaxHeaderSize, Result) -> - {?MODULE, parse_headers, [Data, Header, Headers, MaxHeaderSize, Result]}; -parse_headers(<<Octet, Rest/binary>>, Header, Headers, - MaxHeaderSize, Result) -> - parse_headers(Rest, [Octet | Header], Headers, MaxHeaderSize, Result). - -whole_body(Body, Length) -> - case size(Body) of - N when N < Length, Length > 0 -> - {?MODULE, whole_body, [Body, Length]}; - N when N >= Length, Length >= 0 -> - %% When a client uses pipelining trailing data - %% may be part of the next request! - %% Trailing data will be separated from - %% the actual body in body_data/2. - {ok, Body} - end. - -%% Prevent people from trying to access directories/files -%% relative to the ServerRoot. -validate_uri(RequestURI) -> - UriNoQueryNoHex = - case string:str(RequestURI, "?") of - 0 -> - (catch httpd_util:decode_hex(RequestURI)); - Ndx -> - (catch httpd_util:decode_hex(string:left(RequestURI, Ndx))) - end, - case UriNoQueryNoHex of - {'EXIT',_Reason} -> - {error, {bad_request, {malformed_syntax, RequestURI}}}; - _ -> - Path = format_request_uri(UriNoQueryNoHex), - Path2=[X||X<-string:tokens(Path, "/"),X=/="."], %% OTP-5938 - validate_path( Path2,0, RequestURI) - end. - -validate_path([], _, _) -> - ok; -validate_path([".." | _], 0, RequestURI) -> - {error, {bad_request, {forbidden, RequestURI}}}; -validate_path([".." | Rest], N, RequestURI) -> - validate_path(Rest, N - 1, RequestURI); -validate_path([_ | Rest], N, RequestURI) -> - validate_path(Rest, N + 1, RequestURI). - -%%---------------------------------------------------------------------- -%% 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. -%%---------------------------------------------------------------------- -format_request_uri("*")-> - "*"; -format_request_uri("http://" ++ ServerAndPath) -> - remove_server(ServerAndPath); - -format_request_uri("HTTP://" ++ ServerAndPath) -> - remove_server(ServerAndPath); - -format_request_uri(ABSPath) -> - ABSPath. - -remove_server([]) -> - "/"; -remove_server([$\/|Url])-> - case Url of - []-> - "/"; - _-> - [$\/|Url] - end; -remove_server([_|Url]) -> - remove_server(Url). - -format_absolute_uri("http://"++ Uri, _)-> - "HTTP://" ++ Uri; - -format_absolute_uri(OrigUri = "HTTP://" ++ _, _)-> - OrigUri; - -format_absolute_uri(Uri,ParsedHeader)-> - case httpd_util:key1search(ParsedHeader,"host") of - undefined -> - nohost; - Host -> - Host++Uri - end. - -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 - "HTTP/1." ++ NList -> - 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 hd(NList) >= 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. - - -%%---------------------------------------------------------------------- -%% 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) -> - {http_util:to_lower(lists:reverse(Tag)), ""}; -tag([$:|Rest], Tag) -> - {http_util:to_lower(lists:reverse(Tag)), string:strip(Rest)}; -tag([Chr|Rest], Tag) -> - tag(Rest, [Chr|Tag]). - diff --git a/src/couch_inets/httpd_request_handler.erl b/src/couch_inets/httpd_request_handler.erl deleted file mode 100644 index e6764737..00000000 --- a/src/couch_inets/httpd_request_handler.erl +++ /dev/null @@ -1,516 +0,0 @@ -%% ``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$ -%% -%% Description: Implements a request handler process for the HTTP server. -%% - --module(httpd_request_handler). - --behaviour(gen_server). - -%% Application internal API --export([start/2, start/3, socket_ownership_transfered/3]). - -%% gen_server callbacks --export([init/1, handle_call/3, handle_cast/2, handle_info/2, - terminate/2, code_change/3]). - --include("httpd.hrl"). --include("http_internal.hrl"). - --record(state, {mod, %% #mod{} - manager, %% pid() - status, %% accept | busy | blocked - mfa, %% {Module, Function, Args} - max_keep_alive_request = infinity, %% integer() | infinity - response_sent = false, %% true | false - timeout, %% infinity | integer() > 0 - timer, %% ref() - Request timer - headers, %% #http_request_h{} - body %% binary() - }). - -%%==================================================================== -%% Application internal API -%%==================================================================== -%%-------------------------------------------------------------------- -%% Function: start() -> {ok, Pid} | ignore | {error,Error} -%% Description: Starts a httpd-request handler process. Intended to be -%% called by the httpd acceptor process. -%%-------------------------------------------------------------------- -start(Manager, ConfigDB) -> - start(Manager, ConfigDB, 15000). -start(Manager, ConfigDB, AcceptTimeout) -> - proc_lib:start(?MODULE, init, [[Manager, ConfigDB,AcceptTimeout]]). - -%%-------------------------------------------------------------------- -%% socket_ownership_transfered(Pid, SocketType, Socket) -> void() -%% -%% Pid = pid() -%% SocketType = ip_comm | ssl -%% Socket = socket() -%% -%% Description: Send a message to the request handler process -%% confirming that the socket ownership has now sucssesfully been -%% transfered to it. Intended to be called by the httpd acceptor -%% process. -%%-------------------------------------------------------------------- -socket_ownership_transfered(Pid, SocketType, Socket) -> - Pid ! {socket_ownership_transfered, SocketType, Socket}. - -%%-------------------------------------------------------------------- -%% Function: init(Args) -> _ -%% -%% Description: Initiates the server. Obs special init that uses -%% gen_server:enter_loop/3. This is used instead of the normal -%% gen_server callback init, as a more complex init than the -%% gen_server provides is needed. -%%-------------------------------------------------------------------- -init([Manager, ConfigDB,AcceptTimeout]) -> - %% Make sure this process terminates if the httpd manager process - %% should die! - link(Manager), - %% At this point the function httpd_request_handler:start/2 will return. - proc_lib:init_ack({ok, self()}), - - {SocketType, Socket} = await_socket_ownership_transfer(AcceptTimeout), - - Resolve = http_transport:resolve(), - Peername = httpd_socket:peername(SocketType, Socket), - InitData = #init_data{peername = Peername, resolve = Resolve}, - Mod = #mod{config_db = ConfigDB, - socket_type = SocketType, - socket = Socket, - init_data = InitData}, - - MaxHeaderSize = httpd_util:lookup(ConfigDB, max_header_size, - ?HTTP_MAX_HEADER_SIZE), - TimeOut = httpd_util:lookup(ConfigDB, keep_alive_timeout, 150000), - NrOfRequest = httpd_util:lookup(ConfigDB, - max_keep_alive_request, infinity), - - {_, Status} = httpd_manager:new_connection(Manager), - - - State = #state{mod = Mod, manager = Manager, status = Status, - timeout = TimeOut, max_keep_alive_request = NrOfRequest, - mfa = {httpd_request, parse, [MaxHeaderSize]}}, - - NewState = activate_request_timeout(State), - - http_transport:setopts(SocketType, Socket, [binary,{packet, 0}, - {active, once}]), - gen_server:enter_loop(?MODULE, [], NewState). - -%%==================================================================== -%% gen_server callbacks -%%==================================================================== - -%%-------------------------------------------------------------------- -%% handle_call(Request, From, State) -> {reply, Reply, State} | -%% {reply, Reply, State, Timeout} | -%% {noreply, State} | -%% {noreply, State, Timeout} | -%% {stop, Reason, Reply, State} | -%% {stop, Reason, State} -%% Description: Handling call messages -%%-------------------------------------------------------------------- -handle_call(Request, From, State) -> - {stop, {call_api_violation, Request, From}, State}. - -%%-------------------------------------------------------------------- -%% handle_cast(Msg, State) -> {noreply, State} | -%% {noreply, State, Timeout} | -%% {stop, Reason, State} -%% Description: Handling cast messages -%%-------------------------------------------------------------------- -handle_cast(Msg, State) -> - {reply, {cast_api_violation, Msg}, State}. - -%%-------------------------------------------------------------------- -%% handle_info(Info, State) -> {noreply, State} | -%% {noreply, State, Timeout} | -%% {stop, Reason, State} -%% Description: Handling all non call/cast messages -%%-------------------------------------------------------------------- -handle_info({Proto, Socket, Data}, State = - #state{mfa = {Module, Function, Args}, - mod = #mod{socket_type = SockType, - socket = Socket} = ModData} - = State) when Proto == tcp; Proto == ssl; Proto == dummy -> - - case Module:Function([Data | Args]) of - {ok, Result} -> - NewState = cancel_request_timeout(State), - handle_http_msg(Result, NewState); - {error, {header_too_long, MaxHeaderSize}, Version} -> - NewModData = ModData#mod{http_version = Version}, - httpd_response:send_status(NewModData, 413, "Header too big"), - Reason = io_lib:format("Header too big, max size is ~p~n", - [MaxHeaderSize]), - error_log(Reason, NewModData), - {stop, normal, State#state{response_sent = true, - mod = NewModData}}; - NewMFA -> - http_transport:setopts(SockType, Socket, [{active, once}]), - {noreply, State#state{mfa = NewMFA}} - end; - -%% Error cases -handle_info({tcp_closed, _}, State) -> - {stop, normal, State}; -handle_info({ssl_closed, _}, State) -> - {stop, normal, State}; -handle_info({tcp_error, _, _} = Reason, State) -> - {stop, Reason, State}; -handle_info({ssl_error, _, _} = Reason, State) -> - {stop, Reason, State}; - -%% Timeouts -handle_info(timeout, #state{mod = ModData, mfa = {_, parse, _}} = State) -> - error_log("No request received on keep-alive connection" - "before server side timeout", ModData), - %% No response should be sent! - {stop, normal, State#state{response_sent = true}}; -handle_info(timeout, #state{mod = ModData} = State) -> - httpd_response:send_status(ModData, 408, "Request timeout"), - error_log("The client did not send the whole request before the" - "server side timeout", ModData), - {stop, normal, State#state{response_sent = true}}; - -%% Default case -handle_info(Info, #state{mod = ModData} = State) -> - Error = lists:flatten( - io_lib:format("Unexpected message received: ~n~p~n", [Info])), - error_log(Error, ModData), - {noreply, State}. - -%%-------------------------------------------------------------------- -%% terminate(Reason, State) -> void() -%% -%% Description: This function is called by a gen_server when it is about to -%% terminate. It should be the opposite of Module:init/1 and do any necessary -%% cleaning up. When it returns, the gen_server terminates with Reason. -%% The return value is ignored. -%%-------------------------------------------------------------------- -terminate(normal, State) -> - do_terminate(State); -terminate(Reason, #state{response_sent = false, mod = ModData} = State) -> - httpd_response:send_status(ModData, 500, none), - error_log(httpd_util:reason_phrase(500), ModData), - terminate(Reason, State#state{response_sent = true, mod = ModData}); -terminate(_, State) -> - do_terminate(State). - -do_terminate(#state{mod = ModData, manager = Manager} = State) -> - catch httpd_manager:done_connection(Manager), - cancel_request_timeout(State), - httpd_socket:close(ModData#mod.socket_type, ModData#mod.socket). - -%%-------------------------------------------------------------------- -%% code_change(OldVsn, State, Extra) -> {ok, NewState} -%% -%% Description: Convert process state when code is changed -%%-------------------------------------------------------------------- -code_change(_OldVsn, State, _Extra) -> - {ok, State}. - -%%-------------------------------------------------------------------- -%%% Internal functions -%%-------------------------------------------------------------------- -await_socket_ownership_transfer(AcceptTimeout) -> - receive - {socket_ownership_transfered, SocketType, Socket} -> - {SocketType, Socket} - after AcceptTimeout -> - exit(accept_socket_timeout) - end. - -handle_http_msg({_, _, Version, {_, _}, _}, #state{status = busy, - mod = ModData} = State) -> - handle_manager_busy(State#state{mod = - ModData#mod{http_version = Version}}), - {stop, normal, State}; - -handle_http_msg({_, _, Version, {_, _}, _}, - #state{status = blocked, mod = ModData} = State) -> - handle_manager_blocked(State#state{mod = - ModData#mod{http_version = Version}}), - {stop, normal, State}; - -handle_http_msg({Method, Uri, Version, {RecordHeaders, Headers}, Body}, - #state{status = accept, mod = ModData} = State) -> - case httpd_request:validate(Method, Uri, Version) of - ok -> - {ok, NewModData} = - httpd_request:update_mod_data(ModData, Method, Uri, - Version, Headers), - - case is_host_specified_if_required(NewModData#mod.absolute_uri, - RecordHeaders, Version) of - true -> - handle_body(State#state{headers = RecordHeaders, - body = Body, - mod = NewModData}); - false -> - httpd_response:send_status(ModData#mod{http_version = - Version}, - 400, none), - {stop, normal, State#state{response_sent = true}} - end; - {error, {not_supported, What}} -> - httpd_response:send_status(ModData#mod{http_version = Version}, - 501, {Method, Uri, Version}), - Reason = io_lib:format("Not supported: ~p~n", [What]), - error_log(Reason, ModData), - {stop, normal, State#state{response_sent = true}}; - {error, {bad_request, {forbidden, URI}}} -> - httpd_response:send_status(ModData#mod{http_version = Version}, - 403, URI), - Reason = io_lib:format("Forbidden URI: ~p~n", [URI]), - error_log(Reason, ModData), - {stop, normal, State#state{response_sent = true}}; - {error,{bad_request, {malformed_syntax, URI}}} -> - httpd_response:send_status(ModData#mod{http_version = Version}, - 400, URI), - Reason = io_lib:format("Malformed syntax in URI: ~p~n", [URI]), - error_log(Reason, ModData), - {stop, normal, State#state{response_sent = true}} - end; -handle_http_msg({ChunkedHeaders, Body}, - State = #state{headers = Headers}) -> - NewHeaders = http_chunk:handle_headers(Headers, ChunkedHeaders), - handle_response(State#state{headers = NewHeaders, body = Body}); -handle_http_msg(Body, State) -> - handle_response(State#state{body = Body}). - -handle_manager_busy(#state{mod = #mod{config_db = ConfigDB}} = State) -> - MaxClients = httpd_util:lookup(ConfigDB, max_clients, 150), - Reason = io_lib:format("heavy load (>~w processes)", [MaxClients]), - reject_connection(State, lists:flatten(Reason)). - -handle_manager_blocked(State) -> - Reason = "Server maintenance performed, try again later", - reject_connection(State, Reason). - -reject_connection(#state{mod = ModData} = State, Reason) -> - httpd_response:send_status(ModData, 503, Reason), - {stop, normal, State#state{response_sent = true}}. - -is_host_specified_if_required(nohost, #http_request_h{host = undefined}, - "HTTP/1.1") -> - false; -is_host_specified_if_required(_, _, _) -> - true. - -handle_body(#state{mod = #mod{config_db = ConfigDB}} = State) -> - - MaxHeaderSize = - httpd_util:lookup(ConfigDB, max_header_size, ?HTTP_MAX_HEADER_SIZE), - MaxBodySize = httpd_util:lookup(ConfigDB, max_body_size, nolimit), - - case handle_expect(State, MaxBodySize) of - ok -> - handle_body(State, MaxHeaderSize, MaxBodySize); - Other -> - Other - - end. - -handle_body(#state{headers = Headers, body = Body, mod = ModData} = State, - MaxHeaderSize, MaxBodySize) -> - case Headers#http_request_h.'transfer-encoding' of - "chunked" -> - case http_chunk:decode(Body, MaxBodySize, MaxHeaderSize) of - {Module, Function, Args} -> - http_transport:setopts(ModData#mod.socket_type, - ModData#mod.socket, - [{active, once}]), - {noreply, State#state{mfa = - {Module, Function, Args}}}; - {ok, {ChunkedHeaders, NewBody}} -> - NewHeaders = - http_chunk:handle_headers(Headers, ChunkedHeaders), - handle_response(State#state{headers = NewHeaders, - body = NewBody}) - end; - Encoding when list(Encoding) -> - httpd_response:send_status(ModData, 501, - "Unknown Transfer-Encoding"), - Reason = io_lib:format("Unknown Transfer-Encoding: ~p~n", - [Encoding]), - error_log(Reason, ModData), - {stop, normal, State#state{response_sent = true}}; - _ -> - Length = - list_to_integer(Headers#http_request_h.'content-length'), - case ((Length =< MaxBodySize) or (MaxBodySize == nolimit)) of - true -> - case httpd_request:whole_body(Body, Length) of - {Module, Function, Args} -> - http_transport:setopts(ModData#mod.socket_type, - ModData#mod.socket, - [{active, once}]), - {noreply, State#state{mfa = - {Module, Function, Args}}}; - - {ok, NewBody} -> - handle_response( - State#state{headers = Headers, - body = NewBody}) - end; - false -> - httpd_response:send_status(ModData, 413, "Body too big"), - error_log("Body too big", ModData), - {stop, normal, State#state{response_sent = true}} - end - end. - -handle_expect(#state{headers = Headers, mod = - #mod{config_db = ConfigDB} = ModData} = State, - MaxBodySize) -> - Length = Headers#http_request_h.'content-length', - case expect(Headers, ModData#mod.http_version, ConfigDB) of - continue when MaxBodySize > Length; MaxBodySize == nolimit -> - httpd_response:send_status(ModData, 100, ""), - ok; - continue when MaxBodySize < Length -> - httpd_response:send_status(ModData, 413, "Body too big"), - error_log("Body too big", ModData), - {stop, normal, State#state{response_sent = true}}; - {break, Value} -> - httpd_response:send_status(ModData, 417, - "Unexpected expect value"), - Reason = io_lib:format("Unexpected expect value: ~p~n", [Value]), - error_log(Reason, ModData), - {stop, normal, State#state{response_sent = true}}; - no_expect_header -> - ok; - http_1_0_expect_header -> - httpd_response:send_status(ModData, 400, - "Only HTTP/1.1 Clients " - "may use the Expect Header"), - error_log("Client with lower version than 1.1 tried to send" - "an expect header", ModData), - {stop, normal, State#state{response_sent = true}} - end. - -expect(Headers, "HTTP/1.1", _) -> - case Headers#http_request_h.expect of - "100-continue" -> - continue; - undefined -> - no_expect_header; - Other -> - {break, Other} - end; -expect(Headers, _, ConfigDB) -> - case Headers#http_request_h.expect of - undefined -> - no_expect_header; - _ -> - case httpd_util:lookup(ConfigDB, expect, continue) of - continue-> - no_expect_header; - _ -> - http_1_0_expect_header - end - end. - -handle_response(#state{body = Body, mod = ModData, headers = Headers, - max_keep_alive_request = Max} = State) when Max > 0 -> - {NewBody, Data} = httpd_request:body_data(Headers, Body), - ok = httpd_response:generate_and_send_response( - ModData#mod{entity_body = NewBody}), - handle_next_request(State#state{response_sent = true}, Data); - -handle_response(#state{body = Body, headers = Headers, - mod = ModData} = State) -> - {NewBody, _} = httpd_request:body_data(Headers, Body), - ok = httpd_response:generate_and_send_response( - ModData#mod{entity_body = NewBody}), - {stop, normal, State#state{response_sent = true}}. - -handle_next_request(#state{mod = #mod{connection = true} = ModData, - max_keep_alive_request = Max} = State, Data) -> - NewModData = #mod{socket_type = ModData#mod.socket_type, - socket = ModData#mod.socket, - config_db = ModData#mod.config_db, - init_data = ModData#mod.init_data}, - MaxHeaderSize = - httpd_util:lookup(ModData#mod.config_db, - max_header_size, ?HTTP_MAX_HEADER_SIZE), - - TmpState = State#state{mod = NewModData, - mfa = {httpd_request, parse, [MaxHeaderSize]}, - max_keep_alive_request = decrease(Max), - headers = undefined, body = undefined, - response_sent = false}, - - NewState = activate_request_timeout(TmpState), - - case Data of - <<>> -> - http_transport:setopts(ModData#mod.socket_type, - ModData#mod.socket, [{active, once}]), - {noreply, NewState}; - _ -> - handle_info({dummy, ModData#mod.socket, Data}, NewState) - end; - -handle_next_request(State, _) -> - {stop, normal, State}. - -activate_request_timeout(#state{timeout = Time} = State) -> - Ref = erlang:send_after(Time, self(), timeout), - State#state{timer = Ref}. - -cancel_request_timeout(#state{timer = undefined} = State) -> - State; -cancel_request_timeout(#state{timer = Timer} = State) -> - erlang:cancel_timer(Timer), - receive - timeout -> - ok - after 0 -> - ok - end, - State#state{timer = undefined}. - -decrease(N) when integer(N)-> - N-1; -decrease(N) -> - N. - -error_log(ReasonString, #mod{socket = Socket, socket_type = SocketType, - config_db = ConfigDB, - init_data = #init_data{peername = Peername}}) -> - Error = lists:flatten( - io_lib:format("Error reading request: ~s",[ReasonString])), - error_log(mod_log, SocketType, Socket, ConfigDB, Peername, Error), - error_log(mod_disk_log, SocketType, Socket, ConfigDB, Peername, Error). - -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. - diff --git a/src/couch_inets/httpd_response.erl b/src/couch_inets/httpd_response.erl deleted file mode 100644 index a39adc7d..00000000 --- a/src/couch_inets/httpd_response.erl +++ /dev/null @@ -1,377 +0,0 @@ -%% ``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$ -%% --module(httpd_response). --export([generate_and_send_response/1, send_status/3, send_header/3, - send_body/3, send_chunk/3, send_final_chunk/2, split_header/2, - is_disable_chunked_send/1, cache_headers/1]). - --include("httpd.hrl"). --include("http_internal.hrl"). - --define(VMODULE,"RESPONSE"). - -%% If peername does not exist the client already discarded the -%% request so we do not need to send a reply. -generate_and_send_response(#mod{init_data = - #init_data{peername = {_,"unknown"}}}) -> - ok; -generate_and_send_response(#mod{config_db = ConfigDB} = ModData) -> - Modules = httpd_util:lookup(ConfigDB,modules, - [mod_get, mod_head, mod_log]), - case traverse_modules(ModData, Modules) of - done -> - ok; - {proceed, Data} -> - case httpd_util:key1search(Data, status) of - {StatusCode, PhraseArgs, _Reason} -> - send_status(ModData, StatusCode, PhraseArgs), - ok; - undefined -> - case httpd_util:key1search(Data, response) of - {already_sent, _StatusCode, _Size} -> - ok; - {response, Header, Body} -> %% New way - send_response(ModData, Header, Body), - ok; - {StatusCode, Response} -> %% Old way - send_response_old(ModData, StatusCode, Response), - ok; - undefined -> - send_status(ModData, 500, none), - ok - end - end - end. - - -%% traverse_modules - -traverse_modules(ModData,[]) -> - {proceed,ModData#mod.data}; -traverse_modules(ModData,[Module|Rest]) -> - case (catch apply(Module,do,[ModData])) of - {'EXIT', Reason} -> - String = - lists:flatten( - io_lib:format("traverse exit from apply: ~p:do => ~n~p", - [Module, Reason])), - report_error(mod_log, ModData#mod.config_db, String), - report_error(mod_disk_log, ModData#mod.config_db, String), - done; - done -> - done; - {break,NewData} -> - {proceed,NewData}; - {proceed,NewData} -> - traverse_modules(ModData#mod{data=NewData},Rest) - end. - -%% send_status %% - - -send_status(ModData, 100, _PhraseArgs) -> - send_header(ModData, 100, [{content_length, "0"}]); - -send_status(#mod{socket_type = SocketType, - socket = Socket, - config_db = ConfigDB} = ModData, StatusCode, PhraseArgs) -> - - ReasonPhrase = httpd_util:reason_phrase(StatusCode), - Message = httpd_util:message(StatusCode, PhraseArgs, ConfigDB), - Body = get_body(ReasonPhrase, Message), - - send_header(ModData, StatusCode, [{content_type, "text/html"}, - {content_length, integer_to_list(length(Body))}]), - httpd_socket:deliver(SocketType, Socket, Body). - - -get_body(ReasonPhrase, Message)-> - "<HTML> - <HEAD> - <TITLE>"++ReasonPhrase++"</TITLE> - </HEAD> - <BODY> - <H1>"++ReasonPhrase++"</H1>\n"++Message++"\n</BODY> - </HTML>\n". - - -send_response(ModData, Header, Body) -> - 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(ModData, 404, "The file is not availible"); - StatusCode -> - case send_header(ModData, StatusCode, lists:keydelete(code, 1, - Header)) of - ok -> - send_body(ModData, StatusCode, Body); - _ -> - done - end - end. - -send_header(#mod{socket_type = Type, socket = Sock, - http_version = Ver, connection = Conn} = _ModData, - StatusCode, KeyValueTupleHeaders) -> - Headers = create_header(lists:map(fun transform/1, KeyValueTupleHeaders)), - NewVer = case {Ver, StatusCode} of - {[], _} -> - %% May be implicit! - "HTTP/0.9"; - {unknown, 408} -> - %% This will proably never happen! It means the - %% server has timed out the request without - %% receiving a version for the request! Send the - %% lowest version so to ensure that the client - %% will be able to handle it, probably the - %% sensible thing to do! - "HTTP/0.9"; - {undefined,_} -> - "HTTP/1.0"; %% See rfc2145 2.3 last paragraph - _ -> - Ver - end, - StatusLine = [NewVer, " ", io_lib:write(StatusCode), " ", - httpd_util:reason_phrase(StatusCode), ?CRLF], - ConnectionHeader = get_connection(Conn, NewVer), - Head = list_to_binary([StatusLine, Headers, ConnectionHeader , ?CRLF]), - httpd_socket:deliver(Type, Sock, Head). - -send_body(#mod{socket_type = Type, socket = Socket}, _, nobody) -> - httpd_socket:close(Type, Socket), - ok; - -send_body(#mod{socket_type = Type, socket = Sock}, - _StatusCode, Body) when list(Body) -> - ok = httpd_socket:deliver(Type, Sock, Body); - -send_body(#mod{socket_type = Type, socket = Sock} = ModData, - StatusCode, {Fun, Args}) -> - case (catch apply(Fun, Args)) of - close -> - httpd_socket:close(Type, Sock), - done; - - sent -> - {proceed,[{response,{already_sent, StatusCode, - httpd_util:key1search(ModData#mod.data, - content_length)}}]}; - {ok, Body} -> - case httpd_socket:deliver(Type, Sock, Body) of - ok -> - {proceed,[{response, - {already_sent, StatusCode, - httpd_util:key1search(ModData#mod.data, - content_length)}}]}; - _ -> - done - end; - - _ -> - done - end. - -split_header([$: | Value], AccName) -> - Name = http_util:to_lower(string:strip(AccName)), - {lists:reverse(Name), - string:strip(string:strip(string:strip(Value, right, ?LF), right, ?CR))}; -split_header([Char | Rest], AccName) -> - split_header(Rest, [Char | AccName]). - -send_chunk(_, <<>>, _) -> - ok; -send_chunk(_, [], _) -> - ok; - -send_chunk(#mod{http_version = "HTTP/1.1", - socket_type = Type, socket = Sock}, Response0, false) -> - Response = http_chunk:encode(Response0), - httpd_socket:deliver(Type, Sock, Response); - -send_chunk(#mod{socket_type = Type, socket = Sock} = _ModData, Response, _) -> - httpd_socket:deliver(Type, Sock, Response). - -send_final_chunk(#mod{http_version = "HTTP/1.1", - socket_type = Type, socket = Sock}, false) -> - httpd_socket:deliver(Type, Sock, http_chunk:encode_last()); -send_final_chunk(#mod{socket_type = Type, socket = Sock}, _) -> - httpd_socket:close(Type, Sock). - -is_disable_chunked_send(Db) -> - httpd_util:lookup(Db, disable_chunked_transfer_encoding_send, false). - -%% 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(_,_) -> - "". - -cache_headers(#mod{config_db = Db}) -> - case httpd_util:lookup(Db, script_nocache, false) of - true -> - Date = httpd_util:rfc1123_date(), - [{"cache-control", "no-cache"}, - {"pragma", "no-cache"}, - {"expires", Date}]; - false -> - [] - end. - -create_header(KeyValueTupleHeaders) -> - NewHeaders = add_default_headers([{"date", httpd_util:rfc1123_date()}, - {"content-type", "text/html"}, - {"server", ?SERVER_SOFTWARE}], - KeyValueTupleHeaders), - lists:map(fun fix_header/1, NewHeaders). - -fix_header({Key0, Value}) -> - %% make sure first letter is capital - Words1 = string:tokens(Key0, "-"), - Words2 = upify(Words1, []), - Key = new_key(Words2), - Key ++ ": " ++ Value ++ ?CRLF . - -new_key([]) -> - ""; -new_key([W]) -> - W; -new_key([W1,W2]) -> - W1 ++ "-" ++ W2; -new_key([W|R]) -> - W ++ "-" ++ new_key(R). - -upify([], Acc) -> - lists:reverse(Acc); -upify([Key|Rest], Acc) -> - upify(Rest, [upify2(Key)|Acc]). - -upify2([C|Rest]) when C >= $a, C =< $z -> - [C-($a-$A)|Rest]; -upify2(Str) -> - Str. - -add_default_headers([], Headers) -> - Headers; - -add_default_headers([Header = {Default, _} | Defaults], Headers) -> - case lists:keysearch(Default, 1, Headers) of - {value, _} -> - add_default_headers(Defaults, Headers); - _ -> - add_default_headers(Defaults, [Header | Headers]) - end. - -transform({content_type, Value}) -> - {"content-type", Value}; -transform({accept_ranges, Value}) -> - {"accept-ranges", Value}; -transform({cache_control, Value}) -> - {"cache-control",Value}; -transform({transfer_encoding, Value}) -> - {"transfer-encoding", Value}; -transform({content_encoding, Value}) -> - {"content-encoding", Value}; -transform({content_language, Value}) -> - {"content-language", Value}; -transform({retry_after, Value}) -> - {"retry-after", Value}; -transform({content_location, Value}) -> - {"Content-Location:", Value}; -transform({content_length, Value}) -> - {"content-length", Value}; -transform({content_MD5, Value}) -> - {"content-md5", Value}; -transform({content_range, Value}) -> - {"content-range", Value}; -transform({last_modified, Value}) -> - {"last-modified", Value}; -transform({Field, Value}) when is_atom(Field) -> - {atom_to_list(Field), Value}; -transform({Field, Value}) when is_list(Field) -> - {Field, Value}. - -%%---------------------------------------------------------------------- -%% 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{method = "HEAD"} = ModData, - StatusCode, Response) -> - NewResponse = lists:flatten(Response), - - case httpd_util:split(NewResponse, [?CR, ?LF, ?CR, ?LF],2) of - {ok, [Head, Body]} -> - {ok, NewHead} = handle_headers(string:tokens(Head, [?CR,?LF]), []), - send_header(ModData, StatusCode, [{content_length, - content_length(Body)} | NewHead]); - {ok, [NewResponse]} -> - send_header(ModData, StatusCode, [{content_length, - content_length(NewResponse)}]); - _Error -> - send_status(ModData, 500, "Internal Server Error") - end; - -send_response_old(#mod{socket_type = Type, - socket = Sock} = ModData, - StatusCode, Response) -> - - NewResponse = lists:flatten(Response), - - case httpd_util:split(NewResponse, [?CR, ?LF, ?CR, ?LF], 2) of - {ok, [Head, Body]} -> - {ok, NewHead} = handle_headers(string:tokens(Head, - [?CR,?LF]), []), - send_header(ModData, StatusCode, [{content_length, - content_length(Body)} | - NewHead]), - httpd_socket:deliver(Type, Sock, Body); - {ok, [NewResponse]} -> - send_header(ModData, StatusCode, [{content_length, - content_length(NewResponse)}]), - httpd_socket:deliver(Type, Sock, NewResponse); - - {error, _Reason} -> - send_status(ModData, 500, "Internal Server Error") - end. - -content_length(Body)-> - integer_to_list(httpd_util:flatlength(Body)). - -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. - -handle_headers([], NewHeaders) -> - {ok, NewHeaders}; - -handle_headers([Header | Headers], NewHeaders) -> - {FieldName, FieldValue} = split_header(Header, []), - handle_headers(Headers, - [{FieldName, FieldValue}| NewHeaders]). - diff --git a/src/couch_inets/httpd_script_env.erl b/src/couch_inets/httpd_script_env.erl deleted file mode 100644 index d34e9716..00000000 --- a/src/couch_inets/httpd_script_env.erl +++ /dev/null @@ -1,141 +0,0 @@ -%% ``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$ -%% - --module(httpd_script_env). - --export([create_env/3]). - --include("httpd.hrl"). - -%%%========================================================================= -%%% Internal application API -%%%========================================================================= -%%-------------------------------------------------------------------------- -%% create_env(ScriptType, ModData, ScriptElements) -> [{EnvVariable, Value}] -%% -%% ScriptType = cgi | esi -%% ModData = #mod{} -%% ScriptElements = [{Element, Value}] -%% Element = path_info | query_string | entity_body -%% Value = term() -%% EnvVariable = string() - cgi | atom() - esi -%% -%% Description: Creates a list of cgi/esi environment variables and -%% there values. -%%-------------------------------------------------------------------------- -create_env(ScriptType, ModData, ScriptElements) -> - create_basic_elements(ScriptType, ModData) - ++ create_http_header_elements(ScriptType, ModData#mod.parsed_header) - ++ create_script_elements(ScriptType, ModData, ScriptElements) - ++ create_mod_interaction_elements(ScriptType, ModData). - -%%%======================================================================== -%%% Internal functions -%%%======================================================================== -create_basic_elements(esi, ModData) -> - {_, RemoteAddr} = (ModData#mod.init_data)#init_data.peername, - [{server_software, ?SERVER_SOFTWARE}, - {server_name, (ModData#mod.init_data)#init_data.resolve}, - {gateway_interface,?GATEWAY_INTERFACE}, - {server_protocol, ?SERVER_PROTOCOL}, - {server_port, httpd_util:lookup(ModData#mod.config_db,port,80)}, - {request_method, ModData#mod.method}, - {remote_addr, RemoteAddr}, - {script_name, ModData#mod.request_uri}]; - -create_basic_elements(cgi, ModData) -> - {_, RemoteAddr} = (ModData#mod.init_data)#init_data.peername, - [{"SERVER_SOFTWARE",?SERVER_SOFTWARE}, - {"SERVER_NAME", (ModData#mod.init_data)#init_data.resolve}, - {"GATEWAY_INTERFACE",?GATEWAY_INTERFACE}, - {"SERVER_PROTOCOL",?SERVER_PROTOCOL}, - {"SERVER_PORT", - integer_to_list(httpd_util:lookup( - ModData#mod.config_db, port, 80))}, - {"REQUEST_METHOD", ModData#mod.method}, - {"REMOTE_ADDR", RemoteAddr}, - {"SCRIPT_NAME", ModData#mod.request_uri}]. - -create_http_header_elements(ScriptType, Headers) -> - create_http_header_elements(ScriptType, Headers, []). - -create_http_header_elements(_, [], Acc) -> - Acc; -create_http_header_elements(ScriptType, [{Name, [Value | _] = Values } | - Headers], Acc) when list(Value) -> - NewName = lists:map(fun(X) -> if X == $- -> $_; true -> X end end, Name), - Element = http_env_element(ScriptType, NewName, multi_value(Values)), - create_http_header_elements(ScriptType, Headers, [Element | Acc]); - -create_http_header_elements(ScriptType, [{Name, Value} | Headers], Acc) - when list(Value) -> - {ok, NewName, _} = regexp:gsub(Name,"-","_"), - Element = http_env_element(ScriptType, NewName, Value), - create_http_header_elements(ScriptType, Headers, [Element | Acc]). - -http_env_element(cgi, VarName, Value) -> - {"HTTP_"++ http_util:to_upper(VarName), Value}; -http_env_element(esi, VarName, Value) -> - {list_to_atom("http_"++ http_util:to_lower(VarName)), Value}. - -multi_value([]) -> - []; -multi_value([Value]) -> - Value; -multi_value([Value | Rest]) -> - Value ++ ", " ++ multi_value(Rest). - -create_script_elements(ScriptType, ModData, ScriptElements) -> - lists:flatmap(fun({Element, Data}) -> - create_script_elements(ScriptType, - Element, - Data, ModData) - end, ScriptElements). - -create_script_elements(esi, query_string, QueryString, _) -> - [{query_string, QueryString}]; -create_script_elements(cgi, query_string, QueryString, _) -> - [{"QUERY_STRING", QueryString}]; -create_script_elements(esi, path_info, PathInfo, ModData) -> - Aliases = httpd_util:multi_lookup(ModData#mod.config_db, alias), - {_,PathTranslated,_} = - mod_alias:real_name(ModData#mod.config_db, PathInfo, - Aliases), - [{path_info, PathInfo}, - {path_translated, PathTranslated}]; -create_script_elements(cgi, path_info, PathInfo, ModData) -> - Aliases = httpd_util:multi_lookup(ModData#mod.config_db, alias), - {_,PathTranslated,_} = - mod_alias:real_name(ModData#mod.config_db, PathInfo, - Aliases), - [{"PATH_INFO", PathInfo}, - {"PATH_TRANSLATED", PathTranslated}]; -create_script_elements(esi, entity_body, Body, _) -> - [{content_length, httpd_util:flatlength(Body)}]; -create_script_elements(cgi, entity_body, Body, _) -> - [{"CONTENT_LENGTH", httpd_util:flatlength(Body)}]; -create_script_elements(_, _, _, _) -> - []. - -create_mod_interaction_elements(_, ModData)-> - case httpd_util:key1search(ModData#mod.data, remote_user) of - undefined -> - []; - RemoteUser -> - [{remote_user, RemoteUser}] - end. diff --git a/src/couch_inets/httpd_socket.erl b/src/couch_inets/httpd_socket.erl deleted file mode 100644 index 8e6a54f4..00000000 --- a/src/couch_inets/httpd_socket.erl +++ /dev/null @@ -1,62 +0,0 @@ -%% ``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$ -%% --module(httpd_socket). - -%% API (document close ?) --export([deliver/3, peername/2, resolve/0, close/2]). - --include("httpd.hrl"). - --define(VMODULE,"SOCKET"). --include_lib("kernel/include/inet.hrl"). - -deliver(SocketType, Socket, IOListOrBinary) -> - case http_transport:send(SocketType, Socket, IOListOrBinary) of - {error, _Reason} -> - (catch close(SocketType, Socket)), - socket_closed; - _ -> - ok - end. - -peername(SocketType, Socket) -> - http_transport:peername(SocketType, Socket). - -resolve() -> - http_transport:resolve(). - -close(SocketType, Socket) -> - close_sleep(SocketType, 1000), - Res = - case (catch http_transport:close(SocketType, Socket)) of - ok -> ok; - {error,Reason} -> {error,Reason}; - {'EXIT',{noproc,_}} -> {error,closed}; - {'EXIT',Reason} -> {error,Reason}; - Otherwise -> {error,Otherwise} - end, - Res. - -%% Workaround for ssl problem when ssl does not deliver the message -%% sent prior to the close before the close signal. -close_sleep({ssl, _}, Time) -> - sleep(Time); -close_sleep(_, _) -> - ok. - -sleep(T) -> receive after T -> ok end. diff --git a/src/couch_inets/httpd_sup.erl b/src/couch_inets/httpd_sup.erl deleted file mode 100644 index 94573394..00000000 --- a/src/couch_inets/httpd_sup.erl +++ /dev/null @@ -1,137 +0,0 @@ -%% ``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$ -%% -%%---------------------------------------------------------------------- -%% Purpose: The top supervisor for the http server (httpd) hangs under -%% inets_sup. -%%---------------------------------------------------------------------- - --module(httpd_sup). - --behaviour(supervisor). - -%% API --export([start_link/1]). --export([start_child/1, stop_child/2]). - -%% Supervisor callback --export([init/1]). - - -%%%========================================================================= -%%% API -%%%========================================================================= -start_link(HttpdServices) -> - supervisor:start_link({local, ?MODULE}, ?MODULE, [HttpdServices]). - -start_child(ConfigFile) -> - {ok, Spec} = httpd_child_spec(ConfigFile, 15000, []), - supervisor:start_child(?MODULE, Spec). - -stop_child(Addr, Port) -> - Name = {httpd_instance_sup, Addr, Port}, - case supervisor:terminate_child(?MODULE, Name) of - ok -> - supervisor:delete_child(?MODULE, Name); - Error -> - Error - end. - -%%%========================================================================= -%%% Supervisor callback -%%%========================================================================= -init([HttpdServices]) -> - RestartStrategy = one_for_one, - MaxR = 10, - MaxT = 3600, - Children = child_spec(HttpdServices, []), - {ok, {{RestartStrategy, MaxR, MaxT}, Children}}. - -%%%========================================================================= -%%% Internal functions -%%%========================================================================= -%% The format of the httpd service is: -%% httpd_service() -> {httpd,httpd()} -%% httpd() -> [httpd_config()] | file() -%% httpd_config() -> {file,file()} | -%% {debug,debug()} | -%% {accept_timeout,integer()} -%% debug() -> disable | [debug_options()] -%% debug_options() -> {all_functions,modules()} | -%% {exported_functions,modules()} | -%% {disable,modules()} -%% modules() -> [atom()] -child_spec([], Acc) -> - Acc; -child_spec([{httpd, HttpdService} | Rest], Acc) -> - NewHttpdService = mk_tuple_list(HttpdService), - %% Acc2 = child_spec2(NewHttpdService,Acc), - NewAcc= - case catch child_spec2(NewHttpdService) of - {ok,Acc2} -> - [Acc2|Acc]; - {error,Reason} -> - error_msg("failed to create child spec for ~n~p~ndue to: ~p", - [HttpdService,Reason]), -% exit({error,Reason}) - Acc - end, - child_spec(Rest,NewAcc). - -child_spec2(HttpdService) -> - Debug = http_util:key1search(HttpdService,debug,[]), - AcceptTimeout = http_util:key1search(HttpdService,accept_timeout,15000), - ConfigFile = - case http_util:key1search(HttpdService,file) of - undefined -> throw({error,{mandatory_conf_file_missed}}); - File -> File - end, - httpd_util:valid_options(Debug,AcceptTimeout,ConfigFile), - httpd_child_spec(ConfigFile,AcceptTimeout,Debug). - - -httpd_child_spec(ConfigFile,AcceptTimeout,Debug) -> - 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, AcceptTimeout, - Debug, Addr, Port)}; - Error -> - Error - end. - -httpd_child_spec(ConfigFile, AcceptTimeout, Debug, Addr, Port) -> - Name = {httpd_instance_sup, Addr, Port}, - StartFunc = {httpd_instance_sup, start_link, - [ConfigFile,AcceptTimeout,Debug]}, - Restart = permanent, - Shutdown = infinity, - Modules = [httpd_instance_sup], - Type = supervisor, - {Name, StartFunc, Restart, Shutdown, Type, Modules}. - - -mk_tuple_list([]) -> - []; -mk_tuple_list([H={_,_}|T]) -> - [H|mk_tuple_list(T)]; -mk_tuple_list(F) -> - [{file,F}]. - -error_msg(F, A) -> - error_logger:error_msg(F ++ "~n", A). diff --git a/src/couch_inets/httpd_util.erl b/src/couch_inets/httpd_util.erl deleted file mode 100644 index 96fe4238..00000000 --- a/src/couch_inets/httpd_util.erl +++ /dev/null @@ -1,718 +0,0 @@ -%% ``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$ -%% --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, 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, - convert_netscapecookie_date/1, enable_debug/1, valid_options/3]). - --export([encode_hex/1]). --include_lib("kernel/include/file.hrl"). - -%% We will not make the change to use base64 in stdlib in inets just yet. -%% it will be included in the next major release of inets. --compile({nowarn_deprecated_function, {http_base_64, encode, 1}}). --compile({nowarn_deprecated_function, {http_base_64, decode, 1}}). - --deprecated([{to_lower, 1, next_major_release}, - {to_upper, 1, next_major_release}, - {decode_base64, 1, next_major_release}, - {encode_base64, 1, next_major_release} - ]). - -%% 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. - -%%% RFC 2616, HTTP 1.1 Status codes -reason_phrase(100) -> "Continue"; -reason_phrase(101) -> "Switching Protocols" ; -reason_phrase(200) -> "OK" ; -reason_phrase(201) -> "Created" ; -reason_phrase(202) -> "Accepted" ; -reason_phrase(203) -> "Non-Authoritative Information" ; -reason_phrase(204) -> "No Content" ; -reason_phrase(205) -> "Reset Content" ; -reason_phrase(206) -> "Partial Content" ; -reason_phrase(300) -> "Multiple Choices" ; -reason_phrase(301) -> "Moved Permanently" ; -reason_phrase(302) -> "Moved Temporarily" ; -reason_phrase(303) -> "See Other" ; -reason_phrase(304) -> "Not Modified" ; -reason_phrase(305) -> "Use Proxy" ; -reason_phrase(306) -> "(unused)" ; -reason_phrase(307) -> "Temporary Redirect" ; -reason_phrase(400) -> "Bad Request"; -reason_phrase(401) -> "Unauthorized"; -reason_phrase(402) -> "Payment Required"; -reason_phrase(403) -> "Forbidden" ; -reason_phrase(404) -> "Object Not Found" ; -reason_phrase(405) -> "Method Not Allowed" ; -reason_phrase(406) -> "Not Acceptable" ; -reason_phrase(407) -> "Proxy Authentication Required" ; -reason_phrase(408) -> "Request Time-out" ; -reason_phrase(409) -> "Conflict" ; -reason_phrase(410) -> "Gone" ; -reason_phrase(411) -> "Length Required" ; -reason_phrase(412) -> "Precondition Failed" ; -reason_phrase(413) -> "Request Entity Too Large" ; -reason_phrase(414) -> "Request-URI Too Large" ; -reason_phrase(415) -> "Unsupported Media Type" ; -reason_phrase(416) -> "Requested 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(504) -> "Gateway Time-out" ; -reason_phrase(505) -> "HTTP Version not supported"; - -%%% RFC 2518, HTTP Extensions for Distributed Authoring -- WEBDAV -reason_phrase(102) -> "Processing"; -reason_phrase(207) -> "Multi-Status"; -reason_phrase(422) -> "Unprocessable Entity"; -reason_phrase(423) -> "Locked"; -reason_phrase(424) -> "Failed Dependency"; -reason_phrase(507) -> "Insufficient Storage"; - -%%% (Work in Progress) WebDAV Advanced Collections -reason_phrase(425) -> ""; - -%%% RFC 2817, HTTP Upgrade to TLS -reason_phrase(426) -> "Upgrade Required"; - -%%% RFC 3229, Delta encoding in HTTP -reason_phrase(226) -> "IM Used"; - -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(400,Msg,_) -> - "Your browser sent a query that this server could not understand. "++Msg; -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 doesn't understand how to supply -the credentials required."; -message(403,RequestURI,_) -> - "You don't have permission to access "++RequestURI++" on this server."; -message(404,RequestURI,_) -> - "The requested URL "++RequestURI++" was not found on this server."; -message(408, Timeout, _) -> - Timeout; -message(412,none,_) -> - "The requested preconditions where false"; -message(413, Reason,_) -> - "Entity: " ++ Reason; -message(414,ReasonPhrase,_) -> - "Message "++ReasonPhrase++"."; -message(416,ReasonPhrase,_) -> - ReasonPhrase; - -message(500,_,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) -> - if - atom(Method) -> - atom_to_list(Method)++ - " to "++RequestURI++" ("++HTTPVersion++") not supported."; - list(Method) -> - Method++ - " to "++RequestURI++" ("++HTTPVersion++") not supported." - end; - -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) -> - [_WeekDay,Date,Time,_TimeZone|_Rest] = string:tokens(DateStr," "), - convert_rfc850_date(Date,Time). - -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 = http_util: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([_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=http_util: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([_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=http_util: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_netscapecookie_date(Date)-> - case (catch http_util:convert_netscapecookie_date(Date)) of - Ret = {ok, _} -> - Ret; - _ -> - {error,bad_date} - end. - - -%% 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(undefined) -> - undefined; -rfc1123_date(LocalTime) -> - {{YYYY,MM,DD},{Hour,Min,Sec}} = - case calendar:local_time_to_universal_time_dst(LocalTime) of - [Gmt] -> Gmt; - [_,Gmt] -> Gmt - end, - 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==) - -%%% Base-64 decoding (RFC2045) -%% Keep for backward compatibility -decode_base64(Base64) -> - http_base_64:decode(Base64). -encode_base64(ASCII) -> - http_base_64:encode(ASCII). - -%% 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(Str) -> - http_util:to_upper(Str). - -%% to_lower - -to_lower(Str) -> - http_util:to_lower(Str). - - - -%% 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. - -%% 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({A, B, C, D, E, F, G, H}) -> - io_lib:format("~w_~w_~w_~w_~w_~w_~w_~w",[integer_to_hexlist(A), - integer_to_hexlist(B), - integer_to_hexlist(C), - integer_to_hexlist(D), - integer_to_hexlist(E), - integer_to_hexlist(F), - integer_to_hexlist(G), - integer_to_hexlist(H) - ]); -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(List)-> - http_util:hexlist_to_integer(List). - -%%---------------------------------------------------------------------- -%%Converts an integer to an hexlist -%%---------------------------------------------------------------------- -encode_hex(Num)-> - integer_to_hexlist(Num). - -integer_to_hexlist(Num) when is_integer(Num) -> - http_util:integer_to_hexlist(Num). - -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). - - -%%---------------------------------------------------------------------- -%% Enable debugging, validate httpd options -%%---------------------------------------------------------------------- - -enable_debug([]) -> - ok; -enable_debug(Debug) -> - dbg:tracer(), - dbg:p(all, [call]), - do_enable_debug(Debug). - -do_enable_debug(disable) -> - dbg:stop(); -do_enable_debug([]) -> - ok; -do_enable_debug([{Level,Modules}|Rest]) when atom(Level),list(Modules) -> - case Level of - all_functions -> - io:format("Tracing on all functions set on modules: ~p~n", - [Modules]), - lists:foreach(fun(X)->dbg:tpl(X, [{'_', [], [{return_trace}]}]) end,Modules); - exported_functions -> - io:format("Tracing on exported functions set on modules: ~p~n",[Modules]), - lists:foreach(fun(X)->dbg:tp(X, [{'_', [], [{return_trace}]}]) end,Modules); - disable -> - io:format("Tracing disabled on modules: ~p~n",[Modules]), - lists:foreach(fun(X)->dbg:ctp(X) end,Modules); - _ -> - ok - end, - do_enable_debug(Rest). - - - -valid_options(Debug,AcceptTimeout,ConfigFile) -> - valid_debug(Debug), - valid_accept_timeout(AcceptTimeout), - valid_config_file(ConfigFile). -valid_debug([]) -> - ok; -valid_debug(disable) -> - ok; -valid_debug(L) when list(L) -> - valid_debug2(L); -valid_debug(D) -> - throw({error,{bad_debug_option,D}}). -valid_debug2([{all_functions,L}|Rest]) when list(L) -> - test_load_modules(L), - valid_debug2(Rest); -valid_debug2([{exported_functions,L}|Rest]) when list(L) -> - test_load_modules(L), - valid_debug2(Rest); -valid_debug2([{disable,L}|Rest]) when list(L) -> - test_load_modules(L), - valid_debug2(Rest); -valid_debug2([H|_T]) -> - throw({error,{bad_debug_option,H}}); -valid_debug2([]) -> - ok. -valid_accept_timeout(I) when is_integer(I) -> - ok; -valid_accept_timeout(A) -> - throw({error,{bad_debug_option,A}}). -valid_config_file(_) -> - ok. - -test_load_modules([H|T]) when atom(H) -> - case code:which(H) of - non_existing -> - throw({error,{module_does_not_exist,H}}); - _ -> ok - end, - test_load_modules(T); -test_load_modules([H|_T]) -> - throw({error,{module_name_not_atom,H}}); -test_load_modules([]) -> - ok. diff --git a/src/couch_inets/inets.erl b/src/couch_inets/inets.erl deleted file mode 100644 index 0203d8d5..00000000 --- a/src/couch_inets/inets.erl +++ /dev/null @@ -1,34 +0,0 @@ -%% ``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$ -%% -%%---------------------------------------------------------------------- -%% Purpose: The main interface module of the inets application -%%---------------------------------------------------------------------- - --module(inets). - --export([start/0, start/1, stop/0]). - -start() -> - application:start(inets). - -start(Type) -> - application:start(inets, Type). - -stop() -> - application:stop(inets). - diff --git a/src/couch_inets/inets_app.erl b/src/couch_inets/inets_app.erl deleted file mode 100644 index 189c99f7..00000000 --- a/src/couch_inets/inets_app.erl +++ /dev/null @@ -1,28 +0,0 @@ -%% ``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$ -%% --module(inets_app). - --behaviour(application). - --export([start/2, stop/1]). - -start(_Type, _State) -> - supervisor:start_link({local, inets_sup}, inets_sup, []). - -stop(_State) -> - ok. diff --git a/src/couch_inets/inets_internal.hrl b/src/couch_inets/inets_internal.hrl deleted file mode 100644 index fd8d0caa..00000000 --- a/src/couch_inets/inets_internal.hrl +++ /dev/null @@ -1,27 +0,0 @@ -%% ``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$ -%% - --define(CR, $\r). --define(LF, $\n). --define(CRLF, [$\r,$\n]). --define(SP, $\s). --define(TAB, $\t). --define(LEFT_PAREN, $(). --define(RIGHT_PAREN, $)). --define(WHITE_SPACE, $ ). --define(DOUBLE_QUOTE, $"). diff --git a/src/couch_inets/inets_sup.erl b/src/couch_inets/inets_sup.erl deleted file mode 100644 index d0b533cb..00000000 --- a/src/couch_inets/inets_sup.erl +++ /dev/null @@ -1,106 +0,0 @@ -%% ``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$ -%% -%%---------------------------------------------------------------------- -%% Purpose: The top supervisor for the inets application -%%---------------------------------------------------------------------- - --module(inets_sup). - --behaviour(supervisor). - --export([init/1]). - -%%%========================================================================= -%%% Supervisor callback -%%%========================================================================= -init([]) -> - SupFlags = {one_for_one, 10, 3600}, - Children = children(), - {ok, {SupFlags, Children}}. - -%%%========================================================================= -%%% Internal functions -%%%========================================================================= -get_services() -> - case (catch application:get_env(inets, services)) of - {ok, Services} -> - Services; - _ -> - [] - end. - -children() -> - Services = get_services(), - HttpdServices = [Service || Service <- Services, is_httpd(Service)], - HttpcServices = [Service || Service <- Services, is_httpc(Service)], - TftpdServices = [Service || Service <- Services, is_tftpd(Service)], - [ftp_child_spec(), httpc_child_spec(HttpcServices), - httpd_child_spec(HttpdServices), tftpd_child_spec(TftpdServices)]. - -ftp_child_spec() -> - Name = ftp_sup, - StartFunc = {ftp_sup, start_link, []}, - Restart = permanent, - Shutdown = infinity, - Modules = [ftp_sup], - Type = supervisor, - {Name, StartFunc, Restart, Shutdown, Type, Modules}. - -httpc_child_spec(HttpcServices) -> - Name = httpc_sup, - StartFunc = {httpc_sup, start_link, [HttpcServices]}, - Restart = permanent, - Shutdown = infinity, - Modules = [httpc_sup], - Type = supervisor, - {Name, StartFunc, Restart, Shutdown, Type, Modules}. - -httpd_child_spec(HttpdServices) -> - Name = httpd_sup, - StartFunc = {httpd_sup, start_link, [HttpdServices]}, - Restart = permanent, - Shutdown = infinity, - Modules = [httpd_sup], - Type = supervisor, - {Name, StartFunc, Restart, Shutdown, Type, Modules}. - -tftpd_child_spec(TftpServices) -> - Name = tftp_sup, - StartFunc = {tftp_sup, start_link, [TftpServices]}, - Restart = permanent, - Shutdown = infinity, - Modules = [tftp_sup], - Type = supervisor, - {Name, StartFunc, Restart, Shutdown, Type, Modules}. - -is_httpd({httpd, _}) -> - true; -is_httpd({httpd, _, _}) -> - true; -is_httpd(_) -> - false. - -is_httpc({httpc, _}) -> - true; -is_httpc(_) -> - false. - -is_tftpd({tftpd, _}) -> - true; -is_tftpd(_) -> - false. diff --git a/src/couch_inets/mod_actions.erl b/src/couch_inets/mod_actions.erl deleted file mode 100644 index 3447196c..00000000 --- a/src/couch_inets/mod_actions.erl +++ /dev/null @@ -1,92 +0,0 @@ -%% ``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$ -%% --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("Action "++ 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("Script " ++ 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/src/couch_inets/mod_alias.erl b/src/couch_inets/mod_alias.erl deleted file mode 100644 index 703e0d1e..00000000 --- a/src/couch_inets/mod_alias.erl +++ /dev/null @@ -1,180 +0,0 @@ -%% ``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$ -%% --module(mod_alias). - --export([do/1, - real_name/3, - real_script_name/3, - default_index/2, - load/2, - path/3]). - --include("httpd.hrl"). - --define(VMODULE,"ALIAS"). - -%% 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 -> - do_alias(Info); - %% A response has been generated or sent! - _Response -> - {proceed, Info#mod.data} - end - end. - -do_alias(Info) -> - {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 /= $/ -> - 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("DirectoryIndex " ++ DirectoryIndex, []) -> - {ok, DirectoryIndexes} = regexp:split(DirectoryIndex," "), - {ok,[], {directory_index, DirectoryIndexes}}; -load("Alias " ++ 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("ScriptAlias " ++ 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/src/couch_inets/mod_auth.erl b/src/couch_inets/mod_auth.erl deleted file mode 100644 index e94699fe..00000000 --- a/src/couch_inets/mod_auth.erl +++ /dev/null @@ -1,784 +0,0 @@ -%% ``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$ -%% --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"). - -%% We will not make the change to use base64 in stdlib in inets just yet. -%% it will be included in the next major release of inets. --compile({nowarn_deprecated_function, {http_base_64, encode, 1}}). - --define(VMODULE,"AUTH"). - --define(NOPASSWORD,"NoPassword"). - -%% 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), - %% 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_required, 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 - undefined -> - authorization_required(DirectoryData); - %% Check credentials! - "Basic" ++ EncodedString = Credentials -> - case (catch http_base_64:decode(EncodedString)) of - {'EXIT',{function_clause, _}} -> - {status, {401, none, ?NICE("Bad credentials "++ - Credentials)}}; - DecodedString -> - validate_user(Info, Directory, DirectoryData, - ValidUsers, ValidGroups, - DecodedString) - end; - %% Bad credentials! - BadCredentials -> - {status, {401, none, ?NICE("Bad credentials "++ - BadCredentials)}} - end - end. - -authorization_required(DirectoryData) -> - case httpd_util:key1search(DirectoryData, auth_name) of - undefined -> - {status,{500, none,?NICE("AuthName directive not specified")}}; - Realm -> - {authorization_required, Realm} - end. - - -validate_user(Info, Directory, DirectoryData, ValidUsers, - ValidGroups, DecodedString) -> - case a_valid_user(Info, DecodedString, - ValidUsers, ValidGroups, - Directory, DirectoryData) of - {yes, User} -> - {authorized, User}; - {no, _Reason} -> - authorization_required(DirectoryData); - {status, {StatusCode,PhraseArgs,Reason}} -> - {status,{StatusCode,PhraseArgs,Reason}} - 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; - _ -> - 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}; - _ -> - {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]) -> - case regexp:match(RemoteAddr, HostRegExp) of - {match,_,_} -> - true; - nomatch -> - validate_addr(RemoteAddr,Rest) - end. - -%% deny - -deny({_,RemoteAddr}, _SocketType, _Socket,DirectoryData) -> - Hosts = httpd_util:key1search(DirectoryData, deny_from, none), - 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("<Directory " ++ 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("AuthName " ++ AuthName, [{directory,Directory, DirData}|Rest]) -> - {ok, [{directory,Directory, - [ {auth_name, httpd_conf:clean(AuthName)}|DirData]} | Rest ]}; - -load("AuthUserFile " ++ 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("AuthAccessPassword " ++ AuthAccessPassword0, - [{directory,Directory, DirData}|Rest]) -> - AuthAccessPassword = httpd_conf:clean(AuthAccessPassword0), - {ok,[{directory,Directory, - [{auth_access_password, AuthAccessPassword}|DirData]} | Rest]}; - - - - -load("AuthDBType " ++ 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("require " ++ 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("allow " ++ 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("deny " ++ 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]) -> - directory_config_check(Directory, DirData), - {ok, Rest, {directory, Directory, DirData}}; - -load("AuthMnesiaDB " ++ 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. - -directory_config_check(Directory, DirData) -> - case httpd_util:key1search(DirData,auth_type) of - plain -> - check_filename_present(Directory,auth_user_file,DirData), - check_filename_present(Directory,auth_group_file,DirData); - undefined -> - throw({error, - ?NICE("Server configuration missed AuthDBType directive")}); - _ -> - ok - end. -check_filename_present(_Dir,AuthFile,DirData) -> - case httpd_util:key1search(DirData,AuthFile) of - Name when list(Name) -> - ok; - _ -> - throw({error,?NICE("Server configuration missed "++ - directive(AuthFile)++" directive")}) - end. - -directive(auth_user_file) -> - "AuthUserFile"; -directive(auth_group_file) -> - "AuthGroupFile". - -%% 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, 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) - 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/src/couch_inets/mod_auth.hrl b/src/couch_inets/mod_auth.hrl deleted file mode 100644 index d49c97bc..00000000 --- a/src/couch_inets/mod_auth.hrl +++ /dev/null @@ -1,27 +0,0 @@ -%% ``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$ -%% - --record(httpd_user, - {username, - password, - user_data}). - --record(httpd_group, - {name, - userlist}). - diff --git a/src/couch_inets/mod_auth_dets.erl b/src/couch_inets/mod_auth_dets.erl deleted file mode 100644 index f63457dc..00000000 --- a/src/couch_inets/mod_auth_dets.erl +++ /dev/null @@ -1,228 +0,0 @@ -%% ``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$ -%% --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}}; - _ -> - {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), - {ok, Groups} = list_groups(DirData), - lists:foreach(fun(Group) -> - delete_group_member(DirData, - Group, UserName) end, - Groups), - 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}; - _ -> - {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/src/couch_inets/mod_auth_mnesia.erl b/src/couch_inets/mod_auth_mnesia.erl deleted file mode 100644 index 6c122565..00000000 --- a/src/couch_inets/mod_auth_mnesia.erl +++ /dev/null @@ -1,282 +0,0 @@ -%% ``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$ -%% --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 of course 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}}; - _ -> - {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/src/couch_inets/mod_auth_plain.erl b/src/couch_inets/mod_auth_plain.erl deleted file mode 100644 index ad6bb999..00000000 --- a/src/couch_inets/mod_auth_plain.erl +++ /dev/null @@ -1,295 +0,0 @@ -%% ``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$ -%% --module(mod_auth_plain). - --include("httpd.hrl"). --include("mod_auth.hrl"). - --define(VMODULE,"AUTH_PLAIN"). - -%% 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) -> - 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) -> - 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), - Records = ets:match(PWDB, '$1'), - {ok, lists:foldr(fun({User, _PassWd, _Data}, A) -> [User | A] end, - [], lists:flatten(Records))}. - -delete_user(DirData, UserName) -> - PWDB = httpd_util:key1search(DirData, auth_user_file), - case ets:lookup(PWDB, UserName) of - [{UserName, _SomePassword, _SomeData}] -> - ets:delete(PWDB, UserName), - {ok, Groups} = list_groups(DirData), - lists:foreach(fun(Group) -> - delete_group_member(DirData, - Group, UserName) - end, Groups); - _ -> - {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) -> - GDB = httpd_util:key1search(DirData, auth_group_file), - case ets:lookup(GDB, Group) of - [{Group, Users}] -> - case lists:member(UserName, Users) of - true -> - true; - false -> - ets:insert(GDB, {Group, [UserName|Users]}), - true - end; - [] -> - ets:insert(GDB, {Group, [UserName]}), - true; - Other -> - {error, Other} - end. - -list_group_members(DirData, Group) -> - GDB = httpd_util:key1search(DirData, auth_group_file), - case ets:lookup(GDB, Group) of - [{Group, Users}] -> - {ok, Users}; - _ -> - {error, no_such_group} - end. - -list_groups(DirData) -> - GDB = httpd_util:key1search(DirData, auth_group_file), - Groups = ets:match(GDB, '$1'), - {ok, httpd_util:uniq(lists:foldr(fun({G, _}, A) -> [G|A] end, - [], lists:flatten(Groups)))}. - -delete_group_member(DirData, Group, User) -> - GDB = httpd_util:key1search(DirData, auth_group_file), - case ets:lookup(GDB, Group) of - [{Group, Users}] when is_list(Users) -> - case lists:member(User, Users) of - true -> - ets:delete(GDB, Group), - ets:insert(GDB, {Group, lists:delete(User, Users)}), - true; - false -> - {error, no_such_group_member} - end; - _ -> - {error, no_such_group} - end. - -delete_group(DirData, Group) -> - GDB = httpd_util:key1search(DirData, auth_group_file), - case ets:lookup(GDB, Group) of - [{Group, _Users}] -> - ets:delete(GDB, Group), - true; - _ -> - {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, Err} - end; - 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/src/couch_inets/mod_auth_server.erl b/src/couch_inets/mod_auth_server.erl deleted file mode 100644 index 8e9cf9e8..00000000 --- a/src/couch_inets/mod_auth_server.erl +++ /dev/null @@ -1,374 +0,0 @@ -%% ``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$ -%% - --module(mod_auth_server). - --include("httpd.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]). - -%% gen_server exports --export([start_link/2, init/1, - handle_call/3, handle_cast/2, handle_info/2, - terminate/2, code_change/3]). - -%% We will not make the change to use base64 in stdlib in inets just yet. -%% it will be included in the next major release of inets. --compile({nowarn_deprecated_function, {http_base_64, encode, 1}}). - --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)-> - Name = make_name(Addr, Port), - gen_server:start_link({local, Name}, ?MODULE, [], [{timeout, infinity}]). - - -%% start/2 - -start(Addr, Port)-> - Name = make_name(Addr, Port), - case whereis(Name) of - undefined -> - httpd_misc_sup:start_auth_server(Addr, Port); - _ -> %% Already started... - ok - end. - - -%% stop/2 - -stop(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. - -%% 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(_) -> - {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_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) -> - {ok, {state, Tab, undefined}}; - - -%% code_change(FromVsn, State, Extra) -%% -code_change(_, {state, Tab, _}, 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), - (catch apply(AuthMod, Func, [DirData|Args])); - _ -> - {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/src/couch_inets/mod_browser.erl b/src/couch_inets/mod_browser.erl deleted file mode 100644 index 03eb66bb..00000000 --- a/src/couch_inets/mod_browser.erl +++ /dev/null @@ -1,247 +0,0 @@ -%% ``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$ -%% -%% ---------------------------------------------------------------------- -%% -%% 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 -%% some axamples: -%% -%% Netscape Mozilla/4.75 [en] (X11; U; SunOS 5.8 sun4u) -%% Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.0.1) Gecko/20020823 Netscape/7.0 -%% Mozilla Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.1) Gecko/20020827 -%% Safari Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en-us) AppleWebKit/85 (KHTML, like Gecko) Safari/85 -%% 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). - --export([do/1, test/0, getBrowser/1]). - -%% 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,[{netscape, "netscape"}, - {opera, "opera"}, - {msie, "msie"}, - {safari, "safari"}, - {mozilla, "rv:"}]). % fallback, must be last - - -%% 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"]}, - {macosx, ["mac os x"]}]). - --define(LYNX, lynx). --define(MOZILLA, mozilla). --define(EMACS, emacs). --define(STAROFFICE, soffice). --define(MOSAIC, mosaic). --define(NETSCAPE, netscape). --define(SAFARU, safari). --define(UNKOWN, unknown). - --include("httpd.hrl"). - --define(VMODULE,"BROWSER"). - -do(Info) -> - case httpd_util:key1search(Info#mod.data,status) of - {_StatusCode, _PhraseArgs, _Reason} -> - {proceed,Info#mod.data}; - undefined -> - Browser = getBrowser1(Info), - {proceed,[{'user-agent', Browser}|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 = http_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([$s,$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 -%% are not the default mozillaborwser against the regexp -%% for the different browsers. if no match, it is a mozilla -%% browser i.e opera, netscape, ie or safari - -getMozilla(_AgentString,[],Default) -> - Default; -getMozilla(AgentString,[{Agent,AgentRegExp}|Rest],Default) -> - case regexp:match(AgentString,AgentRegExp) of - {match,_,_} -> - {Agent,getMozVersion(AgentString,AgentRegExp)}; - nomatch -> - getMozilla(AgentString,Rest,Default) - end. - -getMozVersion(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 - case strip(VsnString) of - [] -> - unknown; - [Y1,Y2,Y3,Y4,M1,M2,D1,D2] = DateVsn when - Y1 =< $9, Y1 >= $0, - Y2 =< $9, Y2 >= $0, - Y3 =< $9, Y3 >= $0, - Y4 =< $9, Y4 >= $0, - M1 =< $9, M1 >= $0, - M2 =< $9, M2 >= $0, - D1 =< $9, D1 >= $0, - D2 =< $9, D2 >= $0 -> - list_to_integer(DateVsn); - Vsn -> - case string:tokens(Vsn,".") of - [Number]-> - list_to_float(Number++".0"); - [Major,Minor|Rev] -> - V = lists:flatten([Major,".",Minor,Rev]), - list_to_float(V) - end - end; - nomatch -> - unknown - end. - -strip(VsnString) -> - strip2(strip1(VsnString)). - -strip1(VsnString) -> - string:strip(VsnString,both,$\ ). - -strip2(VsnString) -> - string:strip(VsnString,both,$/ ). - -test()-> - test("Mozilla/4.75 [en] (X11; U; SunOS 5.8 sun4u)"), - test("Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.0.1) Gecko/20020823 Netscape/7.0"), - test("Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.1) Gecko/20020827"), - test("Mozilla/5.0 (Macintosh; U; PPC Mac OS X Mach-O; en-US; rv:1.4) Gecko/20020827"), - test("Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en-us) AppleWebKit/85 (KHTML, like Gecko) Safari/85"), - test("Mozilla/4.0 (compatible; MSIE 5.0; SP1B; SunOS 5.8 sun4u; X11)"), - test("Lynx/2.8.3rel.1 libwww-FM/2.142"), - ok. - -test(Str) -> - Browser = getBrowser(Str), - io:format("~n--------------------------------------------------------~n"), - io:format("~p",[Browser]), - io:format("~n--------------------------------------------------------~n"). - diff --git a/src/couch_inets/mod_cgi.erl b/src/couch_inets/mod_cgi.erl deleted file mode 100644 index 0e682d84..00000000 --- a/src/couch_inets/mod_cgi.erl +++ /dev/null @@ -1,331 +0,0 @@ -%% ``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$ -%% -%% Implements The WWW Common Gateway Interface Version 1.1 - --module(mod_cgi). - --export([env/3]). - -%%% Callback API --export([do/1, load/2]). - --include("http_internal.hrl"). --include("httpd.hrl"). - -%% We will not make the change to use base64 in stdlib in inets just yet. -%% it will be included in the next major release of inets. --compile({nowarn_deprecated_function, {http_base_64, encode, 1}}). - --define(VMODULE,"CGI"). - --define(DEFAULT_CGI_TIMEOUT, 15000). - -%%%========================================================================= -%%% API -%%%========================================================================= -%%-------------------------------------------------------------------------- -%% do(ModData, _, AfterScript) -> [{EnvVariable, Value}] -%% -%% AfterScript = string() -%% ModData = #mod{} -%% EnvVariable = string() -%% Value = term() -%% Description: Keep for now as it is documented in the man page -%%------------------------------------------------------------------------- -env(ModData, _Script, AfterScript) -> - ScriptElements = script_elements(ModData, AfterScript), - httpd_script_env:create_env(cgi, ModData, ScriptElements). - -%%%========================================================================= -%%% Callback API -%%%========================================================================= - -%%-------------------------------------------------------------------------- -%% do(ModData) -> {proceed, OldData} | {proceed, NewData} | {break, NewData} -%% | done -%% ModData = #mod{} -%% -%% Description: See httpd(3) ESWAPI CALLBACK FUNCTIONS -%%------------------------------------------------------------------------- -do(ModData) -> - case httpd_util:key1search(ModData#mod.data, status) of - %% A status code has been generated! - {_StatusCode, _PhraseArgs, _Reason} -> - {proceed, ModData#mod.data}; - %% No status code has been generated! - undefined -> - case httpd_util:key1search(ModData#mod.data, response) of - undefined -> - generate_response(ModData); - _Response -> - {proceed, ModData#mod.data} - end - end. - -%%-------------------------------------------------------------------------- -%% load(Line, Context) -> eof | ok | {ok, NewContext} | -%% {ok, NewContext, Directive} | -%% {ok, NewContext, DirectiveList} | {error, Reason} -%% Line = string() -%% Context = NewContext = DirectiveList = [Directive] -%% Directive = {DirectiveKey , DirectiveValue} -%% DirectiveKey = DirectiveValue = term() -%% Reason = term() -%% -%% Description: See httpd(3) ESWAPI CALLBACK FUNCTIONS -%%------------------------------------------------------------------------- - -%% ScriptNoCache true|false, defines whether the server shall add -%% header fields to stop proxies and -%% clients from saving the page in history -%% or cache -%% -load("ScriptNoCache " ++ 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; -%% ScriptTimeout Seconds, The number of seconds that the server -%% maximum will wait for the script to -%% generate a part of the document -load("ScriptTimeout " ++ 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. - -%%%======================================================================== -%%% Internal functions -%%%======================================================================== -generate_response(ModData) -> - RequestURI = - case httpd_util:key1search(ModData#mod.data, new_request_uri) of - undefined -> - ModData#mod.request_uri; - Value -> - Value - end, - ScriptAliases = - httpd_util:multi_lookup(ModData#mod.config_db, script_alias), - case mod_alias:real_script_name(ModData#mod.config_db, RequestURI, - ScriptAliases) of - {Script, AfterScript} -> - exec_script(ModData, Script, AfterScript, - RequestURI); - not_a_script -> - {proceed, ModData#mod.data} - end. - -is_executable(File) -> - Dir = filename:dirname(File), - FileName = filename:basename(File), - case os:type() of - {win32,_} -> - %% temporary (hopefully) fix for win32 OTP-3627 - is_win32_executable(Dir,FileName); - _ -> - is_executable(Dir, FileName) - end. - -is_executable(Dir, FilName) -> - case os:find_executable(FilName, Dir) of - false -> - false; - _ -> - true - end. - -%% Start temporary (hopefully) fix for win32 OTP-3627 -%% --------------------------------- -is_win32_executable(Dir, FileName) -> - NewFileName = strip_extention(FileName, [".bat",".exe",".com", ".cmd"]), - is_executable(Dir, NewFileName). - -strip_extention(FileName, []) -> - FileName; -strip_extention(FileName, [Extention | Extentions]) -> - case filename:basename(FileName, Extention) of - FileName -> - strip_extention(FileName, Extentions); - NewFileName -> - NewFileName - end. - -%% End fix -%% --------------------------------- - -exec_script(ModData, Script, AfterScript, RequestURI) -> - exec_script(is_executable(Script), ModData, Script, - AfterScript, RequestURI). - -exec_script(true, ModData, Script, AfterScript, _RequestURI) -> - process_flag(trap_exit,true), - Dir = filename:dirname(Script), - ScriptElements = script_elements(ModData, AfterScript), - Env = (catch httpd_script_env:create_env(cgi, ModData, ScriptElements)), - - %% Run script - Port = (catch open_port({spawn, Script},[binary, stream, - {cd, Dir}, {env, Env}])), - case Port of - Port when is_port(Port) -> - send_request_body_to_script(ModData, Port), - deliver_webpage(ModData, Port); % Take care of script output - Error -> - exit({open_port_failed, Error, - [{mod,?MODULE}, - {uri,ModData#mod.request_uri}, {script,Script}, - {env,Env},{dir,Dir}]}) - end; - -exec_script(false, ModData, _Script, _AfterScript, _RequestURI) -> - {proceed, - [{status, - {404,ModData#mod.request_uri, - ?NICE("You don't have permission to execute " ++ - ModData#mod.request_uri ++ " on this server")}}| - ModData#mod.data]}. - -send_request_body_to_script(ModData, Port) -> - case ModData#mod.entity_body of - [] -> - ok; - EntityBody -> - port_command(Port, EntityBody) - end. - -deliver_webpage(#mod{config_db = Db} = ModData, Port) -> - Timeout = cgi_timeout(Db), - case receive_headers(Port, httpd_cgi, parse_headers, - [<<>>, [], []], Timeout) of - {Headers, Body} -> - case httpd_cgi:handle_headers(Headers) of - {proceed, AbsPath} -> - {proceed, [{real_name, - httpd_util:split_path(AbsPath)} | - ModData#mod.data]}; - {ok, HTTPHeaders, Status} -> - IsDisableChunkedSend = - httpd_response:is_disable_chunked_send(Db), - case (ModData#mod.http_version =/= "HTTP/1.1") or - (IsDisableChunkedSend) of - true -> - send_headers(ModData, Status, - [{"connection", "close"} - | HTTPHeaders]); - false -> - send_headers(ModData, Status, - [{"transfer-encoding", - "chunked"} | HTTPHeaders]) - end, - handle_body(Port, ModData, Body, Timeout, size(Body), - IsDisableChunkedSend) - end; - {'EXIT', Port, Reason} -> - process_flag(trap_exit, false), - {proceed, [{status, {400, none, reason(Reason)}} | - ModData#mod.data]}; - timeout -> - (catch port_close(Port)), % KILL the port !!!! - send_headers(ModData, {504, "Timeout"}, []), - httpd_socket:close(ModData#mod.socket_type, ModData#mod.socket), - process_flag(trap_exit,false), - {proceed,[{response, {already_sent, 200, 0}} | ModData#mod.data]} - end. - -receive_headers(Port, Module, Function, Args, Timeout) -> - receive - {Port, {data, Response}} when is_port(Port) -> - case Module:Function([Response | Args]) of - {NewModule, NewFunction, NewArgs} -> - receive_headers(Port, NewModule, - NewFunction, NewArgs, Timeout); - {ok, {Headers, Body}} -> - {Headers, Body} - end; - {'EXIT', Port, Reason} when is_port(Port) -> - {'EXIT', Port, Reason}; - {'EXIT', Pid, Reason} when is_pid(Pid) -> - exit({linked_process_died, Pid, Reason}) - after Timeout -> - timeout - end. - -send_headers(ModData, {StatusCode, _}, HTTPHeaders) -> - ExtraHeaders = httpd_response:cache_headers(ModData), - httpd_response:send_header(ModData, StatusCode, - ExtraHeaders ++ HTTPHeaders). - -handle_body(Port, #mod{method = "HEAD"} = ModData, _, _, Size, _) -> - (catch port_close(Port)), % KILL the port !!!! - process_flag(trap_exit,false), - {proceed, [{response, {already_sent, 200, Size}} | ModData#mod.data]}; - -handle_body(Port, ModData, Body, Timeout, Size, IsDisableChunkedSend) -> - httpd_response:send_chunk(ModData, Body, IsDisableChunkedSend), - receive - {Port, {data, Data}} when port(Port) -> - handle_body(Port, ModData, Data, Timeout, Size + size(Data), - IsDisableChunkedSend); - {'EXIT', Port, normal} when is_port(Port) -> - httpd_response:send_final_chunk(ModData, IsDisableChunkedSend), - process_flag(trap_exit,false), - {proceed, [{response, {already_sent, 200, Size}} | - ModData#mod.data]}; - {'EXIT', Port, Reason} when is_port(Port) -> - process_flag(trap_exit, false), - {proceed, [{status, {400, none, reason(Reason)}} | - ModData#mod.data]}; - {'EXIT', Pid, Reason} when is_pid(Pid) -> - exit({mod_cgi_linked_process_died, Pid, Reason}) - after Timeout -> - (catch port_close(Port)), % KILL the port !!!! - process_flag(trap_exit,false), - {proceed,[{response, {already_sent, 200, Size}} | - ModData#mod.data]} - end. - -script_elements(#mod{method = "GET"}, {[], QueryString}) -> - [{query_string, QueryString}]; -script_elements(#mod{method = "GET"}, {PathInfo, []}) -> - [{path_info, PathInfo}]; -script_elements(#mod{method = "GET"}, {PathInfo, QueryString}) -> - [{query_string, QueryString}, {path_info, PathInfo}]; -script_elements(#mod{method = "POST", entity_body = Body}, _) -> - [{entity_body, Body}]; -script_elements(_, _) -> - []. - -cgi_timeout(Db) -> - httpd_util:lookup(Db, cgi_timeout, ?DEFAULT_CGI_TIMEOUT). - -%% 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(Reason) -> lists:flatten(io_lib:format("Reason: ~p~n", [Reason])). diff --git a/src/couch_inets/mod_dir.erl b/src/couch_inets/mod_dir.erl deleted file mode 100644 index 7ec3306d..00000000 --- a/src/couch_inets/mod_dir.erl +++ /dev/null @@ -1,281 +0,0 @@ -%% ``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$ -%% --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} -> - LastModified = - case (catch httpd_util:rfc1123_date( - FileInfo#file_info.mtime)) of - Date when is_list(Date) -> - [{"date", Date}]; - _ -> %% This will rarly happen, but could happen - %% if a computer is wrongly configured. - [] - end, - Head=[{content_type,"text/html"}, - {content_length, - integer_to_list(httpd_util:flatlength(Dir))}, - {code,200} | LastModified], - {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]), - Status = httpd_file:handle_error(Reason, "access", Info, - DefaultPath), - {proceed, [{status, Status}| 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.0" - "w-~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.0" - "w-~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. - - diff --git a/src/couch_inets/mod_disk_log.erl b/src/couch_inets/mod_disk_log.erl deleted file mode 100644 index 3c29b9e1..00000000 --- a/src/couch_inets/mod_disk_log.erl +++ /dev/null @@ -1,396 +0,0 @@ -%% ``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$ -%% --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.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(_, _,[]) -> - 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} -> - {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/src/couch_inets/mod_esi.erl b/src/couch_inets/mod_esi.erl deleted file mode 100644 index f0e8ae80..00000000 --- a/src/couch_inets/mod_esi.erl +++ /dev/null @@ -1,432 +0,0 @@ -%% ``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$ -%% --module(mod_esi). - -%% API -%% Functions provided to help erl scheme alias programmer to -%% Create dynamic webpages that are sent back to the user during -%% Generation --export([deliver/2]). - -%% Callback API --export([do/1, load/2]). - --include("httpd.hrl"). - --define(VMODULE,"ESI"). --define(DEFAULT_ERL_TIMEOUT,15000). - -%%%========================================================================= -%%% API -%%%========================================================================= -%%-------------------------------------------------------------------------- -%% deliver(SessionID, Data) -> ok | {error, bad_sessionID} -%% SessionID = pid() -%% Data = string() | io_list() (first call must send a string that -%% contains all header information including "\r\n\r\n", unless there -%% is no header information at all.) -%% -%% Description: Send <Data> (Html page generated sofar) to the server -%% request handling process so it can forward it to the client. -%%------------------------------------------------------------------------- -deliver(SessionID, Data) when pid(SessionID) -> - SessionID ! {ok, Data}, - ok; -deliver(_SessionID, _Data) -> - {error, bad_sessionID}. - -%%%========================================================================= -%%% CALLBACK API -%%%========================================================================= -%%-------------------------------------------------------------------------- -%% do(ModData) -> {proceed, OldData} | {proceed, NewData} | {break, NewData} -%% | done -%% ModData = #mod{} -%% -%% Description: See httpd(3) ESWAPI CALLBACK FUNCTIONS -%%------------------------------------------------------------------------- -do(ModData) -> - case httpd_util:key1search(ModData#mod.data, status) of - {_StatusCode, _PhraseArgs, _Reason} -> - {proceed, ModData#mod.data}; - undefined -> - case httpd_util:key1search(ModData#mod.data, response) of - undefined -> - generate_response(ModData); - _Response -> - {proceed, ModData#mod.data} - end - end. -%%-------------------------------------------------------------------------- -%% load(Line, Context) -> eof | ok | {ok, NewContext} | -%% {ok, NewContext, Directive} | -%% {ok, NewContext, DirectiveList} | {error, Reason} -%% Line = string() -%% Context = NewContext = DirectiveList = [Directive] -%% Directive = {DirectiveKey , DirectiveValue} -%% DirectiveKey = DirectiveValue = term() -%% Reason = term() -%% -%% Description: See httpd(3) ESWAPI CALLBACK FUNCTIONS -%%------------------------------------------------------------------------- -load("ErlScriptAlias " ++ 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("EvalScriptAlias " ++ 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("ErlScriptTimeout " ++ 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("ErlScriptNoCache " ++ 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. - -%%%======================================================================== -%%% Internal functions -%%%======================================================================== -generate_response(ModData) -> - case scheme(ModData#mod.request_uri, ModData#mod.config_db) of - {eval, ESIBody, Modules} -> - eval(ModData, ESIBody, Modules); - {erl, ESIBody, Modules} -> - erl(ModData, ESIBody, Modules); - no_scheme -> - {proceed, ModData#mod.data} - end. - -scheme(RequestURI, ConfigDB) -> - case match_script(RequestURI, ConfigDB, erl_script_alias) of - no_match -> - case match_script(RequestURI, ConfigDB, eval_script_alias) of - no_match -> - no_scheme; - {EsiBody, ScriptModules} -> - {eval, EsiBody, ScriptModules} - end; - {EsiBody, ScriptModules} -> - {erl, EsiBody, ScriptModules} - end. - -match_script(RequestURI, ConfigDB, AliasType) -> - case httpd_util:multi_lookup(ConfigDB, AliasType) of - [] -> - no_match; - AliasAndMods -> - match_esi_script(RequestURI, AliasAndMods, AliasType) - end. - -match_esi_script(_, [], _) -> - no_match; -match_esi_script(RequestURI, [{Alias,Modules} | Rest], AliasType) -> - AliasMatchStr = alias_match_str(Alias, AliasType), - case regexp:first_match(RequestURI, AliasMatchStr) of - {match, 1, Length} -> - {string:substr(RequestURI, Length + 1), Modules}; - nomatch -> - match_esi_script(RequestURI, Rest, AliasType) - end. - -alias_match_str(Alias, erl_script_alias) -> - "^" ++ Alias ++ "/"; -alias_match_str(Alias, eval_script_alias) -> - "^" ++ Alias ++ "\\?". - - -%%------------------------ Erl mechanism -------------------------------- - -erl(#mod{method = Method} = ModData, ESIBody, Modules) - when Method == "GET"; Method == "HEAD"-> - case httpd_util:split(ESIBody,":|%3A|/",2) of - {ok, [Module, FuncAndInput]} -> - case httpd_util:split(FuncAndInput,"[\?/]",2) of - {ok, [FunctionName, Input]} -> - generate_webpage(ModData, ESIBody, Modules, - Module, FunctionName, Input, - script_elements(FunctionName, Input)); - {ok, [FunctionName]} -> - generate_webpage(ModData, ESIBody, Modules, - Module, FunctionName, "", - script_elements(FunctionName, "")); - {ok, BadRequest} -> - {proceed,[{status,{400,none, BadRequest}} | - ModData#mod.data]} - end; - {ok, BadRequest} -> - {proceed, [{status,{400, none, BadRequest}} | ModData#mod.data]} - end; - -erl(#mod{method = "POST", entity_body = Body} = ModData, ESIBody, Modules) -> - case httpd_util:split(ESIBody,":|%3A|/",2) of - {ok,[Module, Function]} -> - generate_webpage(ModData, ESIBody, Modules, Module, - Function, Body, [{entity_body, Body}]); - {ok, BadRequest} -> - {proceed,[{status, {400, none, BadRequest}} | ModData#mod.data]} - end. - -generate_webpage(ModData, ESIBody, ["all"], ModuleName, FunctionName, - Input, ScriptElements) -> - generate_webpage(ModData, ESIBody, [ModuleName], ModuleName, - FunctionName, Input, ScriptElements); -generate_webpage(ModData, ESIBody, Modules, ModuleName, FunctionName, - Input, ScriptElements) -> - case lists:member(ModuleName, Modules) of - true -> - Env = httpd_script_env:create_env(esi, ModData, ScriptElements), - Module = list_to_atom(ModuleName), - Function = list_to_atom(FunctionName), - case erl_scheme_webpage_chunk(Module, Function, - Env, Input, ModData) of - {error, erl_scheme_webpage_chunk_undefined} -> - erl_scheme_webpage_whole(Module, Function, Env, Input, - ModData); - ResponseResult -> - ResponseResult - end; - false -> - {proceed, [{status, {403, ModData#mod.request_uri, - ?NICE("Client not authorized to evaluate: " - ++ ESIBody)}} | ModData#mod.data]} - end. - -%% Old API that waits for the dymnamic webpage to be totally generated -%% before anythig is sent back to the client. -erl_scheme_webpage_whole(Module, Function, Env, Input, ModData) -> - case (catch Module:Function(Env, Input)) of - {'EXIT',Reason} -> - {proceed, [{status, {500, none, Reason}} | - ModData#mod.data]}; - Response -> - {Headers, Body} = - httpd_esi:parse_headers(lists:flatten(Response)), - Length = httpd_util:flatlength(Body), - case httpd_esi:handle_headers(Headers) of - {proceed, AbsPath} -> - {proceed, [{real_name, httpd_util:split_path(AbsPath)} - | ModData#mod.data]}; - {ok, NewHeaders, StatusCode} -> - send_headers(ModData, StatusCode, - [{"content-length", - integer_to_list(Length)}| NewHeaders]), - case ModData#mod.method of - "HEAD" -> - {proceed, [{response, {already_sent, 200, 0}} | - ModData#mod.data]}; - _ -> - httpd_response:send_body(ModData, - StatusCode, Body), - {proceed, [{response, {already_sent, 200, - Length}} | - ModData#mod.data]} - end - end - end. - -%% New API that allows the dynamic wepage to be sent back to the client -%% in small chunks at the time during generation. -erl_scheme_webpage_chunk(Mod, Func, Env, Input, ModData) -> - process_flag(trap_exit, true), - Self = self(), - %% Spawn worker that generates the webpage. - %% 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 - Pid = spawn_link( - fun() -> - case catch Mod:Func(Self, Env, Input) of - {'EXIT',{undef,_}} -> - %% Will force fallback on the old API - exit(erl_scheme_webpage_chunk_undefined); - _ -> - ok - end - end), - - Response = deliver_webpage_chunk(ModData, Pid), - - process_flag(trap_exit,false), - Response. - -deliver_webpage_chunk(#mod{config_db = Db} = ModData, Pid) -> - Timeout = erl_script_timeout(Db), - deliver_webpage_chunk(ModData, Pid, Timeout). - -deliver_webpage_chunk(#mod{config_db = Db} = ModData, Pid, Timeout) -> - case receive_headers(Timeout) of - {error, Reason} -> - %% Happens when webpage generator callback/3 is undefined - {error, Reason}; - {Headers, Body} -> - case httpd_esi:handle_headers(Headers) of - {proceed, AbsPath} -> - {proceed, [{real_name, httpd_util:split_path(AbsPath)} - | ModData#mod.data]}; - {ok, NewHeaders, StatusCode} -> - IsDisableChunkedSend = - httpd_response:is_disable_chunked_send(Db), - case (ModData#mod.http_version =/= "HTTP/1.1") or - (IsDisableChunkedSend) of - true -> - send_headers(ModData, StatusCode, - [{"connection", "close"} | - NewHeaders]); - false -> - send_headers(ModData, StatusCode, - [{"transfer-encoding", - "chunked"} | NewHeaders]) - end, - handle_body(Pid, ModData, Body, Timeout, length(Body), - IsDisableChunkedSend) - end; - timeout -> - send_headers(ModData, {504, "Timeout"},[{"connection", "close"}]), - httpd_socket:close(ModData#mod.socket_type, ModData#mod.socket), - process_flag(trap_exit,false), - {proceed,[{response, {already_sent, 200, 0}} | ModData#mod.data]} - end. - -receive_headers(Timeout) -> - receive - {ok, Chunk} -> - httpd_esi:parse_headers(lists:flatten(Chunk)); - {'EXIT', Pid, erl_scheme_webpage_chunk_undefined} when is_pid(Pid) -> - {error, erl_scheme_webpage_chunk_undefined}; - {'EXIT', Pid, Reason} when is_pid(Pid) -> - exit({mod_esi_linked_process_died, Pid, Reason}) - after Timeout -> - timeout - end. - -send_headers(ModData, StatusCode, HTTPHeaders) -> - ExtraHeaders = httpd_response:cache_headers(ModData), - httpd_response:send_header(ModData, StatusCode, - ExtraHeaders ++ HTTPHeaders). - -handle_body(_, #mod{method = "HEAD"} = ModData, _, _, Size, _) -> - process_flag(trap_exit,false), - {proceed, [{response, {already_sent, 200, Size}} | ModData#mod.data]}; - -handle_body(Pid, ModData, Body, Timeout, Size, IsDisableChunkedSend) -> - httpd_response:send_chunk(ModData, Body, IsDisableChunkedSend), - receive - {ok, Data} -> - handle_body(Pid, ModData, Data, Timeout, Size + length(Data), - IsDisableChunkedSend); - {'EXIT', Pid, normal} when is_pid(Pid) -> - httpd_response:send_final_chunk(ModData, IsDisableChunkedSend), - {proceed, [{response, {already_sent, 200, Size}} | - ModData#mod.data]}; - {'EXIT', Pid, Reason} when is_pid(Pid) -> - exit({mod_esi_linked_process_died, Pid, Reason}) - after Timeout -> - process_flag(trap_exit,false), - {proceed,[{response, {already_sent, 200, Size}} | - ModData#mod.data]} - end. - -erl_script_timeout(Db) -> - httpd_util:lookup(Db, erl_script_timeout, ?DEFAULT_ERL_TIMEOUT). - -script_elements(FuncAndInput, Input) -> - case input_type(FuncAndInput) of - path_info -> - [{path_info, Input}]; - query_string -> - [{query_string, Input}]; - _ -> - [] - end. - -input_type([]) -> - no_input; -input_type([$/|_Rest]) -> - path_info; -input_type([$?|_Rest]) -> - query_string; -input_type([_First|Rest]) -> - input_type(Rest). - -%%------------------------ Eval mechanism -------------------------------- - -eval(#mod{request_uri = ReqUri, method = "POST", - http_version = Version, data = Data}, _ESIBody, _Modules) -> - {proceed,[{status,{501,{"POST", ReqUri, Version}, - ?NICE("Eval mechanism doesn't support method POST")}}| - Data]}; - -eval(#mod{method = Method} = ModData, ESIBody, Modules) - when Method == "GET"; Method == "HEAD" -> - case is_authorized(ESIBody, Modules) of - true -> - case generate_webpage(ESIBody) of - {error, Reason} -> - {proceed, [{status, {500, none, Reason}} | - ModData#mod.data]}; - {ok, Response} -> - {Headers, _} = - httpd_esi:parse_headers(lists:flatten(Response)), - case httpd_esi:handle_headers(Headers) of - {ok, _, StatusCode} -> - {proceed,[{response, {StatusCode, Response}} | - ModData#mod.data]}; - {proceed, AbsPath} -> - {proceed, [{real_name, AbsPath} | - ModData#mod.data]} - end - end; - false -> - {proceed,[{status, - {403, ModData#mod.request_uri, - ?NICE("Client not authorized to evaluate: " - ++ ESIBody)}} | ModData#mod.data]} - end. - -generate_webpage(ESIBody) -> - (catch lib:eval_str(string:concat(ESIBody,". "))). - -is_authorized(_ESIBody, ["all"]) -> - true; -is_authorized(ESIBody, Modules) -> - case regexp:match(ESIBody, "^[^\:(%3A)]*") of - {match, Start, Length} -> - lists:member(string:substr(ESIBody, Start, Length), Modules); - nomatch -> - false - end. diff --git a/src/couch_inets/mod_get.erl b/src/couch_inets/mod_get.erl deleted file mode 100644 index b3c59875..00000000 --- a/src/couch_inets/mod_get.erl +++ /dev/null @@ -1,125 +0,0 @@ -%% ``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$ -%% --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), - Size = integer_to_list(FileInfo#file_info.size), - Headers = case Info#mod.http_version of - "HTTP/1.1" -> - [{content_type, MimeType}, - {etag, httpd_util:create_etag(FileInfo)}, - {content_length, Size}|LastModified]; - %% OTP-4935 - _ -> - %% i.e http/1.0 and http/0.9 - [{content_type, MimeType}, - {content_length, Size}|LastModified] - end, - send(Info, 200, Headers, FileDescriptor), - file:close(FileDescriptor), - {proceed,[{response,{already_sent,200, - FileInfo#file_info.size}}, - {mime_type,MimeType}|Info#mod.data]}; - {error, Reason} -> - Status = httpd_file:handle_error(Reason, "open", Info, Path), - {proceed, - [{status, Status}| Info#mod.data]} - end. - -%% send - -send(#mod{socket = Socket, socket_type = SocketType} = Info, - StatusCode, Headers, FileDescriptor) -> - ?DEBUG("send -> send header",[]), - httpd_response:send_header(Info, StatusCode, Headers), - send_body(SocketType,Socket,FileDescriptor). - - -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. - -get_modification_date(Path)-> - {ok, FileInfo0} = file:read_file_info(Path), - LastModified = - case catch httpd_util:rfc1123_date(FileInfo0#file_info.mtime) of - Date when is_list(Date) -> [{last_modified, Date}]; - _ -> [] - end, - {FileInfo0, LastModified}. diff --git a/src/couch_inets/mod_head.erl b/src/couch_inets/mod_head.erl deleted file mode 100644 index 3b78ff42..00000000 --- a/src/couch_inets/mod_head.erl +++ /dev/null @@ -1,73 +0,0 @@ -%% ``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$ -%% --module(mod_head). --export([do/1]). - --include("httpd.hrl"). - --define(VMODULE,"HEAD"). - -%% do - -do(Info) -> - 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) -> - 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} -> - Status = httpd_file:handle_error(Reason, "access", Info, Path), - {proceed, - [{status, Status} | Info#mod.data]} - end. diff --git a/src/couch_inets/mod_htaccess.erl b/src/couch_inets/mod_htaccess.erl deleted file mode 100644 index 7f0d454f..00000000 --- a/src/couch_inets/mod_htaccess.erl +++ /dev/null @@ -1,1075 +0,0 @@ -%% ``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$ -%% - --module(mod_htaccess). - --export([do/1, load/2]). - --include("httpd.hrl"). - -%% We will not make the change to use base64 in stdlib in inets just yet. -%% it will be included in the next major release of inets. --compile({nowarn_deprecated_function, {http_base_64, encode, 1}}). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Public methods that interface the eswapi %% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -%---------------------------------------------------------------------- -% Public method called by the webbserver to insert the data about -% Names on accessfiles -%---------------------------------------------------------------------- -load("AccessFileName" ++ FileNames, _Context)-> - CleanFileNames=httpd_conf:clean(FileNames), - {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] = Credentials -> - case (catch http_base_64:decode(EncodedString)) of - {'EXIT',{function_clause, _}} -> - {error, Credentials}; - UnCodedString -> - case httpd_util:split(UnCodedString,":",2) of - {ok,[User,PassWord]}-> - {user,User,PassWord}; - {error,Error}-> - {error,Error} - end - 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}-> - {ok, Members } = getGroupMembers(Groups,AllowedGroups), - authenticateUser(Info,AccessData,{users,Members}, - {user,User,PassWord}); - {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; - _ -> - 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("order"++ 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("allow" ++ 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("deny" ++ 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("require" ++ 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("</Limit" ++ _EndLimit, {Context,FileData})-> - [Context | FileData]; -insertLine("<Limit" ++ 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("AllowOverRide" ++ 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("AuthType" ++ 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 - ["all" ++ _] -> - all; - ["none" ++ _]-> - none; - Directives -> - getOverRideDirectives(Directives) - end. - -getOverRideDirectives(Directives)-> - lists:map(fun(Directive)-> - transformDirective(Directive) - end,Directives). -transformDirective("AuthUserFile" ++ _)-> - user_file; -transformDirective("AuthGroupFile" ++ _) -> - group_file; -transformDirective("AuthName" ++ _)-> - auth_name; -transformDirective("AuthType" ++ _)-> - 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 - "Basic"-> - basic; - "MD5" -> - 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 - "all" -> - all; - _Hosts-> - AllowDenyData - end; - _ -> - error - 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 - "user"-> - {users,UserData}; - "group" -> - {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, _}-> - [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. diff --git a/src/couch_inets/mod_include.erl b/src/couch_inets/mod_include.erl deleted file mode 100644 index c488c778..00000000 --- a/src/couch_inets/mod_include.erl +++ /dev/null @@ -1,594 +0,0 @@ -%% ``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$ -%% --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"). - -%% do - -do(Info) -> - 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) -> - 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 = [{content_type, "text/html"}], - case send_in(Info, Path, HeaderStart, file:read_file_info(Path)) of - {ok, ErrorLog, Size} -> - {proceed, [{response, {already_sent, 200, Size}}, - {mime_type, "text/html"} | - lists:append(ErrorLog, Info#mod.data)]}; - {error, Reason} -> - {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) -> - case file:read_file(Path) of - {ok, Body} -> - {ok, NewContext, NewErrorLog, Result} = - parse(Info, binary_to_list(Body), Context, ErrorLog, []), - {ok, NewContext, 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} = mod_alias:real_name(ConfigDB, RequestURI, Aliases), - - 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(#mod{config_db = Db} = Info, - Context, ErrorLog, [virtual], [VirtualPath],R) -> - Aliases = httpd_util:multi_lookup(Db,alias), - {_,Path, _AfterPath} = mod_alias:real_name(Db, VirtualPath, Aliases), - flastmod(Info,Context,ErrorLog,R,Path); -flastmod(#mod{config_db = Db, request_uri = RequestUri} = Info, - Context, ErrorLog, [file], [FileName], R) -> - Path = file(Db, RequestUri, 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) -> - cmd(Info,Context,ErrorLog,R,Command); -exec(Info,Context,ErrorLog,[cgi],[RequestURI],R) -> - cgi(Info,Context,ErrorLog,R,RequestURI); -exec(_Info, Context, ErrorLog, _TagList, _ValueList, R) -> - {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} -> - exit({open_port_failed,Reason, - [{uri,Info#mod.request_uri},{script,Command}, - {env,Env},{dir,Dir}]}); - 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(#mod{config_db = Db, request_uri = RequestUri} = Info, - Script, _AfterScript, ErrorLog, Context, R) -> - process_flag(trap_exit,true), - Aliases = httpd_util:multi_lookup(Db, alias), - {_, Path, AfterPath} = mod_alias:real_name(Db, RequestUri, 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} -> - exit({open_cmd_failed,Reason, - [{mod,?MODULE},{port,Port}, - {uri,RequestUri}, - {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} -> - exit({open_port_failed,Reason, - [{mod,?MODULE},{uri,RequestUri},{script,Script}, - {env,Env},{dir,Dir}]}); - O -> - exit({open_port_failed,O, - [{mod,?MODULE},{uri,RequestUri},{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} -> - {error, {read,Reason}} - end; -send_in(_Info , _Path, _Head,{error,Reason}) -> - {error, {open,Reason}}. - -send_in1(Info, Data, Head, FileInfo) -> - {ok, _Context, Err, ParsedBody} = parse(Info,Data,?DEFAULT_CONTEXT,[],[]), - Size = length(ParsedBody), - LastModified = case catch httpd_util:rfc1123_date(FileInfo#file_info.mtime) of - Date when list(Date) -> [{last_modified,Date}]; - _ -> [] - end, - Head1 = case Info#mod.http_version of - "HTTP/1.1"-> - Head ++ [{content_length, integer_to_list(Size)}, - {etag, httpd_util:create_etag(FileInfo,Size)}| - LastModified]; - _-> - %% i.e http/1.0 and http/0.9 - Head ++ [{content_length, integer_to_list(Size)}| - LastModified] - end, - httpd_response:send_header(Info, 200, Head1), - httpd_socket:deliver(Info#mod.socket_type,Info#mod.socket, ParsedBody), - {ok, Err, Size}. - - -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) -> - 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} -> - {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) -> - case catch parse5(R1,[],0) of - {parse_error,Reason} -> - parse(Info,R1,Context, - [{internal_info,?NICE(Reason)}|ErrorLog],Result); - {Comment,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) -> - 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) -> - httpd_file:handle_error(Reason, "open", Info, Path); -send_error({read,Reason},Info,Path) -> - httpd_file:handle_error(Reason, "read", Info, Path). - - - - diff --git a/src/couch_inets/mod_log.erl b/src/couch_inets/mod_log.erl deleted file mode 100644 index 9903e69f..00000000 --- a/src/couch_inets/mod_log.erl +++ /dev/null @@ -1,253 +0,0 @@ -%% ``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$ -%% --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"). - -%% 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/src/couch_inets/mod_range.erl b/src/couch_inets/mod_range.erl deleted file mode 100644 index fca7693f..00000000 --- a/src/couch_inets/mod_range.erl +++ /dev/null @@ -1,416 +0,0 @@ -%% ``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$ -%% --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"), - {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)} | - 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"), - Size = get_range_size(Start,Stop,FileInfo), - case valid_range(Start,Stop,FileInfo) of - {true,StartByte,EndByte,TotByte}-> - Head =[{code,206},{content_type, MimeType}, - {etag, httpd_util:create_etag(FileInfo)}, - {content_range,["bytes=", - integer_to_list(StartByte),"-", - integer_to_list(EndByte),"/", - integer_to_list(TotByte)]}, - {content_length, Size} | LastModified], - 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} -> - case (catch httpd_util:rfc1123_date(FileInfo0#file_info.mtime)) of - Date when is_list(Date) -> - {FileInfo0, [{last_modified, Date}]}; - _ -> - {FileInfo0, []} - end; - _ -> - {#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("\bytes\=" ++ Ranges)-> - parse_ranges("bytes\=" ++ Ranges); -parse_ranges("bytes\=" ++ 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/src/couch_inets/mod_responsecontrol.erl b/src/couch_inets/mod_responsecontrol.erl deleted file mode 100644 index b1a330b3..00000000 --- a/src/couch_inets/mod_responsecontrol.erl +++ /dev/null @@ -1,301 +0,0 @@ -%% ``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$ -%% - --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 = calendar:universal_time_to_local_time( - httpd_util:convert_request_date(LastModified0)), - ?DEBUG("control_modification_data() -> " - "~n Request-Field: ~s" - "~n FileLastModified: ~p" - "~n FieldValue: ~p", - [HeaderField, ModificationTime, LastModified]), - 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. - -%% 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([$;,$ | _]) -> - []; -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"), - LastModified = - case (catch httpd_util:rfc1123_date(FileInfo#file_info.mtime)) of - Date when is_list(Date) -> - [{last_modified, Date}]; - _ -> %% This will rarly happen, but could happen - %% if a computer is wrongly configured. - [] - end, - - Header = [{code,304}, - {etag, httpd_util:create_etag(FileInfo)}, - {content_length,"0"}, {mime_type, MimeType} | LastModified], - {response, {response, Header, nobody}}. diff --git a/src/couch_inets/mod_security.erl b/src/couch_inets/mod_security.erl deleted file mode 100644 index dac6d70e..00000000 --- a/src/couch_inets/mod_security.erl +++ /dev/null @@ -1,294 +0,0 @@ -%% ``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$ -%% --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"). - -%% We will not make the change to use base64 in stdlib in inets just yet. -%% it will be included in the next major release of inets. --compile({nowarn_deprecated_function, {http_base_64, encode, 1}}). - --define(VMODULE,"SEC"). - - -%% do/1 -do(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, response) of - %% A status code has been generated! - {401, _Response} -> - 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! - DecodedString = - case (catch - http_base_64:decode( - EncodedString)) of - %% Decode failed - {'EXIT',{function_clause, _}} -> - EncodedString; - String -> - String - end, - - report_failed(Info, DecodedString,"Failed authentication"), - take_failed_action(Info, DecodedString), - {proceed, Info#mod.data} - end; - _ -> - {proceed, Info#mod.data} - end; - User -> - %% A user has been authenticated, now is he blocked ? - 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), - case mod_security_server:check_blocked_user(Info, User, - SDirData, - Addr, Port) of - true -> - report_failed(Info, User ,"User Blocked"), - {proceed, [{status, {403, Info#mod.request_uri, ""}}|Info#mod.data]}; - false -> - report_failed(Info, User,"Authentication Succedded"), - mod_security_server:store_successful_auth(Addr, Port, - User, SDirData), - {proceed, Info#mod.data} - end - end. - -report_failed(Info, Auth, Event) -> - Request = Info#mod.request_line, - {_PortNumber,RemoteHost}=(Info#mod.init_data)#init_data.peername, - String = RemoteHost ++ " : " ++ Event ++ " : " ++ Request ++ " : " ++ Auth, - mod_disk_log:security_log(Info,String), - mod_log:security_log(Info, String). - -take_failed_action(Info, Auth) -> - 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), - mod_security_server:store_failed_auth(Info, Addr, Port, - Auth, 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 -> - {[], []} - 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, _, _} -> - secret_path(Path, Rest, Directory); - nomatch -> - secret_path(Path, Rest, Directory) - end. - - -load("<Directory " ++ 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("SecurityDataFile " ++ FileName, - [{security_directory, Dir, DirData}]) -> - File = httpd_conf:clean(FileName), - {ok, [{security_directory, Dir, [{data_file, File}|DirData]}]}; -load("SecurityCallbackModule " ++ ModuleName, - [{security_directory, Dir, DirData}]) -> - Mod = list_to_atom(httpd_conf:clean(ModuleName)), - {ok, [{security_directory, Dir, [{callback_module, Mod}|DirData]}]}; -load("SecurityMaxRetries " ++ Retries, - [{security_directory, Dir, DirData}]) -> - load_return_int_tag("SecurityMaxRetries", max_retries, - httpd_conf:clean(Retries), Dir, DirData); -load("SecurityBlockTime " ++ Time, - [{security_directory, Dir, DirData}]) -> - load_return_int_tag("SecurityBlockTime", block_time, - httpd_conf:clean(Time), Dir, DirData); -load("SecurityFailExpireTime " ++ Time, - [{security_directory, Dir, DirData}]) -> - load_return_int_tag("SecurityFailExpireTime", fail_expire_time, - httpd_conf:clean(Time), Dir, DirData); -load("SecurityAuthTimeout " ++ Time0, - [{security_directory, Dir, DirData}]) -> - Time = httpd_conf:clean(Time0), - load_return_int_tag("SecurityAuthTimeout", auth_timeout, - httpd_conf:clean(Time), Dir, DirData); -load("AuthName " ++ 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) -> - 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), - - 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). diff --git a/src/couch_inets/mod_security_server.erl b/src/couch_inets/mod_security_server.erl deleted file mode 100644 index 26463faf..00000000 --- a/src/couch_inets/mod_security_server.erl +++ /dev/null @@ -1,628 +0,0 @@ -%% ``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$ -%% -%% 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"). - --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/2, init/1, - handle_info/2, handle_call/3, handle_cast/2, - terminate/2, - code_change/3]). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% %% -%% External API %% -%% %% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -%% start_link/3 -%% -%% NOTE: This is called by httpd_misc_sup when the process is started -%% - -start_link(Addr, Port) -> - Name = make_name(Addr, Port), - gen_server:start_link({local, Name}, ?MODULE, [], [{timeout, infinity}]). - - -%% start/2 -%% Called by the mod_security module. - -start(Addr, Port) -> - Name = make_name(Addr, Port), - case whereis(Name) of - undefined -> - httpd_misc_sup:start_sec_server(Addr, Port); - _ -> %% 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. - - -%% 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(_) -> - process_flag(trap_exit, true), - {ok, []}. - -handle_call(stop, _From, _Tables) -> - {stop, normal, ok, []}; - -handle_call({block_user, User, Addr, Port, Dir, Time}, _From, Tables) -> - Ret = block_user_int({User, Addr, Port, Dir, Time}), - {reply, Ret, Tables}; - -handle_call({list_blocked_users, Addr, Port, Dir}, _From, Tables) -> - Blocked = list_blocked(Tables, Addr, Port, Dir, []), - {reply, Blocked, Tables}; - -handle_call({unblock_user, User, Addr, Port, Dir}, _From, Tables) -> - Ret = unblock_user_int({User, Addr, Port, Dir}), - {reply, Ret, Tables}; - -handle_call({list_auth_users, Addr, Port, Dir}, _From, Tables) -> - Auth = list_auth(Tables, Addr, Port, Dir, []), - {reply, Auth, Tables}; - -handle_call({new_table, Addr, Port, Name}, _From, Tables) -> - case lists:keysearch(Name, 1, Tables) of - {value, {Name, {Ets, Dets}}} -> - {reply, {ok, {Ets, Dets}}, Tables}; - false -> - TName = make_name(Addr,Port,length(Tables)), - 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], - {reply, {ok, {ETS, DFile}}, NewTables}; - {error, Err} -> - {reply, {error, {create_dets, Err}}, Tables} - end - end; - -handle_call(delete_tables, _From, 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) -> - {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), - Ret = - check_blocked_user(Info, User, Dir, Addr, Port, ETS, DETS, CBModule), - {reply, Ret, Tables}; - -handle_call(_Request,_From,Tables) -> - {reply,ok,Tables}. - - -%% handle_cast - -handle_cast({store_failed_auth, [_, _, []]}, Tables) -> - %% Some other authentication scheme than mod_auth (example mod_htacess) - %% was the source for the authentication failure so we should ignor it! - {noreply, Tables}; -handle_cast({store_failed_auth, [Info, DecodedString, SDirData]}, Tables) -> - {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), - Seconds = universal_time(), - Key = {User, Dir, Addr, Port}, - %% Event - CBModule = httpd_util:key1search(SDirData, - callback_module, no_module_at_all), - 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.. - case ets:match_object(ETS, {failed, {Key, '_', '_'}}) of - [] -> - no; - List -> - ExpireTime = httpd_util:key1search(SDirData, - fail_expire_time, 30)*60, - lists:map(fun({failed, {TheKey, LS, Gen}}) -> - Diff = Seconds-LS, - if - Diff > ExpireTime -> - ets:match_delete(ETS, - {failed, - {TheKey, LS, Gen}}), - dets:match_delete(DETS, - {failed, - {TheKey, LS, Gen}}); - true -> - ok - end - end, - List) - end, - - %% Insert the new failure.. - Generation = length(ets:match_object(ETS, {failed, {Key, '_', '_'}})), - 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), - case ets:match_object(ETS, {failed, {Key, '_', '_'}}) of - List1 when length(List1) >= MaxRetries -> - %% Block this user until Future - Future = Seconds+BlockTime*60, - 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, '_', '_'}}); - _ -> - no - end, - {noreply, Tables}; - -handle_cast({store_successful_auth, [User, Addr, Port, SDirData]}, Tables) -> - {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) -> - error_msg("security server got unknown cast: ~p",[Req]), - {noreply, Tables}. - - -%% handle_info - -handle_info(_Info, State) -> - {noreply, State}. - - -%% terminate - -terminate(_Reason, _Tables) -> - ok. - - -%% code_change({down, ToVsn}, State, Extra) -%% -code_change({down, _}, State, _Extra) -> - {ok, State}; - - -%% code_change(FromVsn, State, Extra) -%% -code_change(_, State, _Extra) -> - {ok, State}. - -%% block_user_int/2 -block_user_int({User, Addr, Port, Dir, Time}) -> - Dirs = httpd_manager:config_match(Addr, Port, {security_directory, '_'}), - 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), - 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}) -> - Dirs = httpd_manager:config_match(Addr, Port, {security_directory, '_'}), - case find_dirdata(Dirs, Dir) of - {ok, DirData, {ETS, DETS}} -> - case ets:match_object(ETS, - {blocked_user,{User,Addr,Port,Dir,'_'}}) of - [] -> - {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; - _ -> - {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 -> - 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) - 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) -> - List = ets:match_object(ETS, {blocked_user, - {'_',Addr,Port,Dir,'_'}}), - - NewBlocked = lists:foldl(fun({blocked_user, X}, A) -> - [X|A] end, Acc, List), - - 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(), - BlockList = ets:match_object(ETS, {blocked_user, {User, '_', '_', '_', '_'}}), - Blocked = lists:foldl(fun({blocked_user, X}, A) -> - [X|A] end, [], BlockList), - check_blocked_user(Info,User,Dir, - Addr,Port,ETS,DETS,TN,Blocked,CBModule). - -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}| _], 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/src/couch_inets/mod_trace.erl b/src/couch_inets/mod_trace.erl deleted file mode 100644 index 2ab73e38..00000000 --- a/src/couch_inets/mod_trace.erl +++ /dev/null @@ -1,87 +0,0 @@ -%% ``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$ -%% --module(mod_trace). - --export([do/1]). - --include("httpd.hrl"). - - -do(Info) -> - %%?vtrace("do",[]), - case Info#mod.method of - "TRACE" -> - case 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(Info#mod.request_line ++ 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]). - - - -%%---------------------------------------------------------------------- -%%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/src/couch_inets/tftp.erl b/src/couch_inets/tftp.erl deleted file mode 100644 index 6af1705e..00000000 --- a/src/couch_inets/tftp.erl +++ /dev/null @@ -1,310 +0,0 @@ -%%%------------------------------------------------------------------- -%%% File : tftp.erl -%%% Author : Hakan Mattsson <hakan@erix.ericsson.se> -%%% Description : Trivial FTP -%%% Created : 18 May 2004 by Hakan Mattsson <hakan@erix.ericsson.se> -%%%------------------------------------------------------------------- -%%% -%%% This is a complete implementation of the following IETF standards: -%%% -%%% RFC 1350, The TFTP Protocol (revision 2). -%%% RFC 2347, TFTP Option Extension. -%%% RFC 2348, TFTP Blocksize Option. -%%% RFC 2349, TFTP Timeout Interval and Transfer Size Options. -%%% -%%% The only feature that not is implemented in this release is -%%% the "netascii" transfer mode. -%%% -%%% The start/1 function starts a daemon process which, listens for -%%% UDP packets on a port. When it receives a request for read or -%%% write it spawns a temporary server process which handles the -%%% actual transfer of the file. On the client side the read_file/3 -%%% and write_file/3 functions spawns a temporary client process which -%%% establishes contact with a TFTP daemon and performs the actual -%%% transfer of the file. -%%% -%%% Most of the options are common for both the client and the server -%%% side, but some of them differs a little. Here are the available -%%% options: -%%% -%%% {debug, Level} -%%% -%%% Level = none | brief | normal | verbose | all -%%% -%%% Controls the level of debug printouts. The default is none. -%%% -%%% {host, Host} -%%% -%%% The name or IP address of the host where the TFTP daemon -%%% resides. This option is only used by the client. See -%%% 'inet' about valid host names. -%%% -%%% {port, Port} -%%% -%%% Port = integer() -%%% -%%% The TFTP port where the daemon listens. It defaults to the -%%% standardized number 69. On the server side it may sometimes -%%% make sense to set it to 0, which means that the daemon just -%%% will pick a free port (which is returned by the start/1 -%%% function). -%%% -%%% If a socket has somehow already has been connected, the -%%% {udp, [{fd, integer()}]} option can be used to pass the -%%% open file descriptor to gen_udp. This can be automated -%%% a bit by using a command line argument stating the -%%% prebound file descriptor number. For example, if the -%%% Port is 69 and the file descriptor 22 has been opened by -%%% setuid_socket_wrap. Then the command line argument -%%% "-tftpd_69 22" will trigger the prebound file -%%% descriptor 22 to be used instead of opening port 69. -%%% The UDP option {udp, [{fd, 22}]} autmatically be added. -%%% See init:get_argument/ about command line arguments and -%%% gen_udp:open/2 about UDP options. -%%% -%%% {port_policy, Policy} -%%% -%%% Policy = random | Port | {range, MinPort, MaxPort} -%%% Port = MinPort = MaxPort = integer() -%%% -%%% Policy for the selection of the temporary port which is used -%%% by the server/client during the file transfer. It defaults to -%%% 'random' which is the standardized policy. With this policy a -%%% randomized free port used. A single port or a range of ports -%%% can be useful if the protocol should pass thru a firewall. -%%% -%%% {prebound_fd, InitArgFlag} -%%% -%%% InitArgFlag = atom() -%%% -%%% If a socket has somehow already has been connected, the -%%% {udp, [{fd, integer()}]} option can be used to pass the -%%% open file descriptor to gen_udp. -%%% -%%% The prebound_fd option makes it possible to pass give the -%%% file descriptor as a command line argument. The typical -%%% usage is when used in conjunction with setuid_socket_wrap -%%% to be able to open privileged sockets. For example if the -%%% file descriptor 22 has been opened by setuid_socket_wrap -%%% and you have choosen my_tftp_fd as init argument, the -%%% command line should like this "erl -my_tftp_fd 22" and -%%% FileDesc should be set to my_tftpd_fd. This would -%%% automatically imply {fd, 22} to be set as UDP option. -%%% -%%% {udp, UdpOptions} -%%% -%%% Options to gen_udp:open/2. -%%% -%%% {use_tsize, Bool} -%%% -%%% Bool = boolean() -%%% -%%% Flag for automated usage of the "tsize" option. With this set -%%% to true, the write_file/3 client will determine the filesize -%%% and send it to the server as the standardized "tsize" option. -%%% A read_file/3 client will just acquire filesize from the -%%% server by sending a zero "tsize". -%%% -%%% {max_tsize, MaxTsize} -%%% -%%% MaxTsize = integer() | infinity -%%% -%%% Threshold for the maximal filesize in bytes. The transfer will -%%% be aborted if the limit is exceeded. It defaults to -%%% 'infinity'. -%%% -%%% {max_conn, MaxConn} -%%% -%%% MaxConn = integer() | infinity -%%% -%%% Threshold for the maximal number of active connections. The -%%% daemon will reject the setup of new connections if the limit -%%% is exceeded. It defaults to 'infinity'. -%%% -%%% {TftpKey, TftpVal} -%%% -%%% TftpKey = string() -%%% TftpVal = string() -%%% -%%% The name and value of a TFTP option. -%%% -%%% {reject, Feature} -%%% -%%% Feature = Mode | TftpKey -%%% Mode = read | write -%%% TftpKey = string() -%%% -%%% Control which features that should be rejected. -%%% This is mostly useful for the server as it may restrict -%%% usage of certain TFTP options or read/write access. -%%% -%%% {callback, {RegExp, Module, State}} -%%% -%%% RegExp = string() -%%% Module = atom() -%%% State = term() -%%% -%%% Registration of a callback module. When a file is to be -%%% transferred, its local filename will be matched to the -%%% regular expressions of the registered callbacks. The first -%%% matching callback will be used the during the transfer.The -%%% callback module must implement the 'tftp' behaviour. -%%% -%%% On the server side the callback interaction starts with a -%%% call to open/5 with the registered initial callback -%%% state. open/5 is expected to open the (virtual) file. Then -%%% either the read/1 or write/2 functions are invoked -%%% repeatedly, once per transfererred block. At each function -%%% call the state returned from the previous call is -%%% obtained. When the last block has been encountered the read/1 -%%% or write/2 functions is expected to close the (virtual) -%%% file.and return its last state. The abort/3 function is only -%%% used in error situations. prepare/5 is not used on the server -%%% side. -%%% -%%% On the client side the callback interaction is the same, but -%%% it starts and ends a bit differently. It starts with a call -%%% to prepare/5 with the same arguments as open/5 -%%% takes. prepare/5 is expected to validate the TFTP options, -%%% suggested by the user and return the subset of them that it -%%% accepts. Then the options is sent to the server which will -%%% perform the same TFTP option negotiation procedure. The -%%% options that are accepted by the server is forwarded to the -%%% open/5 function on the client side. On the client side the -%%% open/5 function must accept all option as is or reject the -%%% transfer. Then the callback interaction follows the same -%%% pattern as described above for the server side. When the last -%%% block is encountered in read/1 or write/2 the returned stated -%%% is forwarded to the user and returned from read_file/3 or -%%% write_file/3. -%%%------------------------------------------------------------------- - --module(tftp). - -%%------------------------------------------------------------------- -%% Interface -%%------------------------------------------------------------------- - -%% public functions --export([ - read_file/3, - write_file/3, - start/1, - info/1, - change_config/2, - start/0 - ]). - --export([behaviour_info/1]). - -behaviour_info(callbacks) -> - [{prepare, 6}, {open, 6}, {read, 1}, {write, 2}, {abort, 3}]; -behaviour_info(_) -> - undefined. - --include("tftp.hrl"). - -%%------------------------------------------------------------------- -%% read_file(RemoteFilename, LocalFilename, Options) -> -%% {ok, LastCallbackState} | {error, Reason} -%% -%% RemoteFilename = string() -%% LocalFilename = binary | string() -%% Options = [option()] -%% LastCallbackState = term() -%% Reason = term() -%% -%% Reads a (virtual) file from a TFTP server -%% -%% If LocalFilename is the atom 'binary', tftp_binary will be used as -%% callback module. It will concatenate all transferred blocks and -%% return them as one single binary in the CallbackState. -%% -%% When LocalFilename is a string, it will be matched to the -%% registered callback modules and hopefully one of them will be -%% selected. By default, tftp_file will be used as callback module. It -%% will write each transferred block to the file named -%% LocalFilename. The number of transferred bytes will be returned as -%% LastCallbackState. -%%------------------------------------------------------------------- - -read_file(RemoteFilename, LocalFilename, Options) -> - tftp_engine:client_start(read, RemoteFilename, LocalFilename, Options). - -%%------------------------------------------------------------------- -%% write(RemoteFilename, LocalFilename, Options) -> -%% {ok, LastCallbackState} | {error, Reason} -%% -%% RemoteFilename = string() -%% LocalFilename = binary() | string() -%% Options = [option()] -%% LastCallbackState = term() -%% Reason = term() -%% -%% Writes a (virtual) file to a TFTP server -%% -%% If LocalFilename is a binary, tftp_binary will be used as callback -%% module. The binary will be transferred block by block and the number -%% of transferred bytes will be returned as LastCallbackState. -%% -%% When LocalFilename is a string, it will be matched to the -%% registered callback modules and hopefully one of them will be -%% selected. By default, tftp_file will be used as callback module. It -%% will read the file named LocalFilename block by block. The number -%% of transferred bytes will be returned as LastCallbackState. -%%------------------------------------------------------------------- - -write_file(RemoteFilename, LocalFilename, Options) -> - tftp_engine:client_start(write, RemoteFilename, LocalFilename, Options). - -%%------------------------------------------------------------------- -%% start(Options) -> {ok, Pid} | {error, Reason} -%% -%% Options = [option()] -%% Pid = pid() -%% Reason = term() -%% -%% Starts a daemon process which listens for udp packets on a -%% port. When it receives a request for read or write it spawns -%% a temporary server process which handles the actual transfer -%% of the (virtual) file. -%%------------------------------------------------------------------- - -start(Options) -> - tftp_engine:daemon_start(Options). - -%%------------------------------------------------------------------- -%% info(Pid) -> {ok, Options} | {error, Reason} -%% -%% Options = [option()] -%% Reason = term() -%% -%% Returns info about a tftp daemon, server or client process -%%------------------------------------------------------------------- - -info(Pid) -> - tftp_engine:info(Pid). - -%%------------------------------------------------------------------- -%% change_config(Pid, Options) -> ok | {error, Reason} -%% -%% Options = [option()] -%% Reason = term() -%% -%% Changes config for a tftp daemon, server or client process -%% Must be used with care. -%%------------------------------------------------------------------- - -change_config(Pid, Options) -> - tftp_engine:change_config(Pid, Options). - -%%------------------------------------------------------------------- -%% start() -> ok | {error, Reason} -%% -%% Reason = term() -%% -%% Start the application -%%------------------------------------------------------------------- - -start() -> - application:start(inets). diff --git a/src/couch_inets/tftp.hrl b/src/couch_inets/tftp.hrl deleted file mode 100644 index 40719fa7..00000000 --- a/src/couch_inets/tftp.hrl +++ /dev/null @@ -1,47 +0,0 @@ -%%%------------------------------------------------------------------- -%%% Defines -%%%------------------------------------------------------------------- - --define(TFTP_DEFAULT_PORT, 69).% Default server port - --define(TFTP_OPCODE_RRQ, 1). % Read request --define(TFTP_OPCODE_WRQ, 2). % Write request --define(TFTP_OPCODE_DATA, 3). % Data --define(TFTP_OPCODE_ACK, 4). % Acknowledgement --define(TFTP_OPCODE_ERROR, 5). % Error --define(TFTP_OPCODE_OACK, 6). % Option acknowledgment - --define(TFTP_ERROR_UNDEF, 0). % Not defined, see error message (if any) --define(TFTP_ERROR_ENOENT, 1). % File not found. --define(TFTP_ERROR_EACCES, 2). % Access violation. --define(TFTP_ERROR_ENOSPC, 3). % Disk full or allocation exceeded. --define(TFTP_ERROR_BADOP, 4). % Illegal TFTP operation. --define(TFTP_ERROR_BADBLK, 5). % Unknown transfer ID. --define(TFTP_ERROR_EEXIST, 6). % File already exists. --define(TFTP_ERROR_BADUSER, 7). % No such user. --define(TFTP_ERROR_BADOPT, 8). % Unrequested or illegal option. - --record(tftp_msg_req, {access, filename, mode, options, local_filename}). --record(tftp_msg_data, {block_no, data}). --record(tftp_msg_ack, {block_no}). --record(tftp_msg_error, {code, text, details}). --record(tftp_msg_oack, {options}). - --record(config, {parent_pid = self(), - udp_socket, - udp_options = [binary, {reuseaddr, true}, {active, once}], - udp_host = "localhost", - udp_port = ?TFTP_DEFAULT_PORT, - port_policy = random, - use_tsize = false, - max_tsize = infinity, % Filesize - max_conn = infinity, - rejected = [], - polite_ack = false, - debug_level = none, - timeout, - user_options = [], - callbacks = []}). - --record(callback, {regexp, internal, module, state, block_no, count}). - diff --git a/src/couch_inets/tftp_binary.erl b/src/couch_inets/tftp_binary.erl deleted file mode 100644 index 0850d0cb..00000000 --- a/src/couch_inets/tftp_binary.erl +++ /dev/null @@ -1,181 +0,0 @@ -%%%------------------------------------------------------------------- -%%% File : tft_binary.erl -%%% Author : Hakan Mattsson <hakan@erix.ericsson.se> -%%% Description : -%%% -%%% Created : 24 May 2004 by Hakan Mattsson <hakan@erix.ericsson.se> -%%%------------------------------------------------------------------- - --module(tftp_binary). - -%%%------------------------------------------------------------------- -%%% Interface -%%%------------------------------------------------------------------- - --behaviour(tftp). - --export([prepare/6, open/6, read/1, write/2, abort/3]). --export([prepare/5, open/5]). - --record(read_state, {options, blksize, bin, is_network_ascii, count}). --record(write_state, {options, blksize, list, is_network_ascii}). - -%%------------------------------------------------------------------- -%% Prepare -%%------------------------------------------------------------------- - -prepare(_Peer, Access, Filename, Mode, SuggestedOptions, Initial) -> - %% Kept for backwards compatibility - prepare(Access, Filename, Mode, SuggestedOptions, Initial). - -prepare(Access, Bin, Mode, SuggestedOptions, []) -> - %% Client side - case catch handle_options(Access, Bin, Mode, SuggestedOptions) of - {ok, IsNetworkAscii, AcceptedOptions} when Access =:= read, binary(Bin) -> - State = #read_state{options = AcceptedOptions, - blksize = lookup_blksize(AcceptedOptions), - bin = Bin, - is_network_ascii = IsNetworkAscii, - count = size(Bin)}, - {ok, AcceptedOptions, State}; - {ok, IsNetworkAscii, AcceptedOptions} when Access =:= write, Bin =:= binary -> - State = #write_state{options = AcceptedOptions, - blksize = lookup_blksize(AcceptedOptions), - list = [], - is_network_ascii = IsNetworkAscii}, - {ok, AcceptedOptions, State}; - {error, {Code, Text}} -> - {error, {Code, Text}} - end; -prepare(_Access, _Bin, _Mode, _SuggestedOptions, _Initial) -> - {error, {undef, "Illegal callback options."}}. - -%%------------------------------------------------------------------- -%% Open -%%------------------------------------------------------------------- - -open(_Peer, Access, Filename, Mode, SuggestedOptions, Initial) -> - %% Kept for backwards compatibility - open(Access, Filename, Mode, SuggestedOptions, Initial). - -open(Access, Bin, Mode, SuggestedOptions, []) -> - %% Server side - case prepare(Access, Bin, Mode, SuggestedOptions, []) of - {ok, AcceptedOptions, State} -> - open(Access, Bin, Mode, AcceptedOptions, State); - {error, {Code, Text}} -> - {error, {Code, Text}} - end; -open(Access, Bin, Mode, NegotiatedOptions, State) -> - %% Both sides - IsNetworkAscii = - if - is_record(State, write_state) -> State#write_state.is_network_ascii; - is_record(State, read_state) -> State#read_state.is_network_ascii - end, - case catch handle_options(Access, Bin, Mode, NegotiatedOptions) of - {ok, IsNetworkAscii2, Options} - when Options =:= NegotiatedOptions, - IsNetworkAscii =:= IsNetworkAscii2 -> - {ok, NegotiatedOptions, State}; - {error, {Code, Text}} -> - {error, {Code, Text}} - end. - -%%------------------------------------------------------------------- -%% Read -%%------------------------------------------------------------------- - -read(#read_state{bin = Bin} = State) when is_binary(Bin) -> - BlkSize = State#read_state.blksize, - if - size(Bin) >= BlkSize -> - <<Block:BlkSize/binary, Bin2/binary>> = Bin, - State2 = State#read_state{bin = Bin2}, - {more, Block, State2}; - size(Bin) < BlkSize -> - {last, Bin, State#read_state.count} - end. - -%%------------------------------------------------------------------- -%% Write -%%------------------------------------------------------------------- - -write(Bin, #write_state{list = List} = State) when is_binary(Bin), is_list(List) -> - Size = size(Bin), - BlkSize = State#write_state.blksize, - if - Size =:= BlkSize -> - {more, State#write_state{list = [Bin | List]}}; - Size < BlkSize -> - Bin2 = list_to_binary(lists:reverse([Bin | List])), - {last, Bin2} - end. - -%%------------------------------------------------------------------- -%% Abort -%%------------------------------------------------------------------- - -abort(_Code, _Text, #read_state{bin = Bin} = State) - when record(State, read_state), binary(Bin) -> - ok; -abort(_Code, _Text, #write_state{list = List} = State) - when record(State, write_state), list(List) -> - ok. - -%%------------------------------------------------------------------- -%% Process options -%%------------------------------------------------------------------- - -handle_options(Access, Bin, Mode, Options) -> - IsNetworkAscii = handle_mode(Mode), - Options2 = do_handle_options(Access, Bin, Options), - {ok, IsNetworkAscii, Options2}. - -handle_mode(Mode) -> - case Mode of - %% "netascii" -> true; - "octet" -> false; - _ -> throw({error, {badop, "Illegal mode " ++ Mode}}) - end. - -do_handle_options(Access, Bin, [{Key, Val} | T]) -> - case Key of - "tsize" -> - case Access of - read when Val =:= "0", binary(Bin) -> - Tsize = integer_to_list(size(Bin)), - [{Key, Tsize} | do_handle_options(Access, Bin, T)]; - _ -> - handle_integer(Access, Bin, Key, Val, T, 0, infinity) - end; - "blksize" -> - handle_integer(Access, Bin, Key, Val, T, 8, 65464); - "timeout" -> - handle_integer(Access, Bin, Key, Val, T, 1, 255); - _ -> - do_handle_options(Access, Bin, T) - end; -do_handle_options(_Access, _Bin, []) -> - []. - - -handle_integer(Access, Bin, Key, Val, Options, Min, Max) -> - case catch list_to_integer(Val) of - {'EXIT', _} -> - do_handle_options(Access, Bin, Options); - Int when Int >= Min, Int =< Max -> - [{Key, Val} | do_handle_options(Access, Bin, Options)]; - Int when Int >= Min, Max =:= infinity -> - [{Key, Val} | do_handle_options(Access, Bin, Options)]; - _Int -> - throw({error, {badopt, "Illegal " ++ Key ++ " value " ++ Val}}) - end. - -lookup_blksize(Options) -> - case lists:keysearch("blksize", 1, Options) of - {value, {_, Val}} -> - list_to_integer(Val); - false -> - 512 - end. diff --git a/src/couch_inets/tftp_engine.erl b/src/couch_inets/tftp_engine.erl deleted file mode 100644 index fc494cf6..00000000 --- a/src/couch_inets/tftp_engine.erl +++ /dev/null @@ -1,1121 +0,0 @@ -%%%------------------------------------------------------------------- -%%% File : tftp_engine.erl -%%% Author : Hakan Mattsson <hakan@erix.ericsson.se> -%%% Description : Protocol engine for trivial FTP -%%% -%%% Created : 18 May 2004 by Hakan Mattsson <hakan@erix.ericsson.se> -%%%------------------------------------------------------------------- - --module(tftp_engine). - -%%%------------------------------------------------------------------- -%%% Interface -%%%------------------------------------------------------------------- - -%% application internal functions --export([ - daemon_start/1, - client_start/4, - info/1, - change_config/2 - ]). - -%% module internal --export([ - daemon_init/1, - server_init/2, - client_init/2, - wait_for_msg/3 - ]). - -%% sys callback functions --export([ - system_continue/3, - system_terminate/4, - system_code_change/4 - ]). - --include("tftp.hrl"). - --record(error, {what, code, text}). --define(ERROR(What, Code, Text), #error{what = What, code = Code, text = Text}). - -%%%------------------------------------------------------------------- -%%% Info -%%%------------------------------------------------------------------- - -info(ToPid) when is_pid(ToPid) -> - call(info, ToPid, timer:seconds(10)). - -change_config(ToPid, Options) when is_pid(ToPid) -> - BadKeys = [host, port, udp], - BadOptions = [{Key, Val} || {Key, Val} <- Options, - BadKey <- BadKeys, - Key =:= BadKey], - case BadOptions of - [] -> - call({change_config, Options}, ToPid, timer:seconds(10)); - [{Key, Val} | _] -> - {error, {badarg, {Key, Val}}} - end. - -call(Req, ToPid, Timeout) when is_pid(ToPid) -> - Type = process, - Ref = erlang:monitor(Type, ToPid), - ToPid ! {Req, Ref, self()}, - receive - {Reply, Ref, FromPid} when FromPid =:= ToPid -> - erlang:demonitor(Ref), - Reply; - {'DOWN', Ref, Type, FromPid, _Reason} when FromPid =:= ToPid -> - {error, timeout} - after Timeout -> - {error, timeout} - end. - -reply(Reply, Ref, ToPid) -> - ToPid ! {Reply, Ref, self()}. - -%%%------------------------------------------------------------------- -%%% Daemon -%%%------------------------------------------------------------------- - -%% Returns {ok, Port} -daemon_start(Options) when is_list(Options) -> - Config = tftp_lib:parse_config(Options), - proc_lib:start_link(?MODULE, daemon_init, [Config], infinity). - -daemon_init(Config) when is_record(Config, config), - is_pid(Config#config.parent_pid) -> - process_flag(trap_exit, true), - UdpOptions = prepare_daemon_udp(Config), - case catch gen_udp:open(Config#config.udp_port, UdpOptions) of - {ok, Socket} -> - {ok, ActualPort} = inet:port(Socket), - proc_lib:init_ack({ok, self()}), - Config2 = Config#config{udp_socket = Socket, - udp_port = ActualPort}, - print_debug_info(Config2, daemon, open, #tftp_msg_req{filename = ""}), - daemon_loop(Config2, 0, []); - {error, Reason} -> - Text = lists:flatten(io_lib:format("UDP open ~p -> ~p", [UdpOptions, Reason])), - print_debug_info(Config, daemon, open, ?ERROR(open, undef, Text)), - exit({gen_udp_open, UdpOptions, Reason}); - Reason -> - Text = lists:flatten(io_lib:format("UDP open ~p -> ~p", [UdpOptions, Reason])), - print_debug_info(Config, daemon, open, ?ERROR(open, undef, Text)), - exit({gen_udp_open, UdpOptions, Reason}) - end. - -prepare_daemon_udp(#config{udp_port = Port, udp_options = UdpOptions}) -> - case lists:keymember(fd, 1, UdpOptions) of - true -> - %% Use explicit fd - UdpOptions; - false -> - %% Use fd from setuid_socket_wrap, such as -tftpd_69 - InitArg = list_to_atom("tftpd_" ++ integer_to_list(Port)), - case init:get_argument(InitArg) of - {ok, [[FdStr]] = Badarg} when is_list(FdStr) -> - case catch list_to_integer(FdStr) of - Fd when is_integer(Fd) -> - [{fd, Fd} | UdpOptions]; - {'EXIT', _} -> - exit({badarg, {prebound_fd, InitArg, Badarg}}) - end; - {ok, Badarg} -> - exit({badarg, {prebound_fd, InitArg, Badarg}}); - error -> - UdpOptions - end - end. - -daemon_loop(DaemonConfig, N, Servers) -> - receive - {info, Ref, FromPid} when is_pid(FromPid) -> - ServerInfo = [{n_conn, N} | [{server, P} || P <- Servers]], - Info = internal_info(DaemonConfig, daemon) ++ ServerInfo, - reply({ok, Info}, Ref, FromPid), - daemon_loop(DaemonConfig, N, Servers); - {{change_config, Options}, Ref, FromPid} when is_pid(FromPid) -> - case catch tftp_lib:parse_config(Options, DaemonConfig) of - {'EXIT', Reason} -> - reply({error, Reason}, Ref, FromPid), - daemon_loop(DaemonConfig, N, Servers); - DaemonConfig2 when is_record(DaemonConfig2, config) -> - reply(ok, Ref, FromPid), - daemon_loop(DaemonConfig2, N, Servers) - end; - {udp, Socket, RemoteHost, RemotePort, Bin} when is_binary(Bin) -> - inet:setopts(Socket, [{active, once}]), - ServerConfig = DaemonConfig#config{parent_pid = self(), - udp_host = RemoteHost, - udp_port = RemotePort}, - Msg = (catch tftp_lib:decode_msg(Bin)), - print_debug_info(ServerConfig, daemon, recv, Msg), - case Msg of - Req when is_record(Req, tftp_msg_req), - N < DaemonConfig#config.max_conn -> - Args = [ServerConfig, Req], - Pid = proc_lib:spawn_link(?MODULE, server_init, Args), - daemon_loop(DaemonConfig, N + 1, [Pid | Servers]); - Req when is_record(Req, tftp_msg_req) -> - Reply = #tftp_msg_error{code = enospc, - text = "Too many connections"}, - send_msg(ServerConfig, daemon, Reply), - daemon_loop(DaemonConfig, N, Servers); - {'EXIT', Reply} when is_record(Reply, tftp_msg_error) -> - send_msg(ServerConfig, daemon, Reply), - daemon_loop(DaemonConfig, N, Servers); - Req -> - Reply = #tftp_msg_error{code = badop, - text = "Illegal TFTP operation"}, - error("Daemon received: ~p from ~p:~p", [Req, RemoteHost, RemotePort]), - send_msg(ServerConfig, daemon, Reply), - daemon_loop(DaemonConfig, N, Servers) - end; - {system, From, Msg} -> - Misc = {daemon_loop, [DaemonConfig, N, Servers]}, - sys:handle_system_msg(Msg, From, DaemonConfig#config.parent_pid, ?MODULE, [], Misc); - {'EXIT', Pid, Reason} when DaemonConfig#config.parent_pid =:= Pid -> - close_port(DaemonConfig, daemon, #tftp_msg_req{filename = ""}), - exit(Reason); - {'EXIT', Pid, _Reason} = Info -> - case lists:member(Pid, Servers) of - true -> - daemon_loop(DaemonConfig, N - 1, Servers -- [Pid]); - false -> - error("Daemon received: ~p", [Info]), - daemon_loop(DaemonConfig, N, Servers) - end; - Info -> - error("Daemon received: ~p", [Info]), - daemon_loop(DaemonConfig, N, Servers) - end. - -%%%------------------------------------------------------------------- -%%% Server -%%%------------------------------------------------------------------- - -server_init(Config, Req) when is_record(Config, config), - is_pid(Config#config.parent_pid), - is_record(Req, tftp_msg_req) -> - process_flag(trap_exit, true), - SuggestedOptions = Req#tftp_msg_req.options, - UdpOptions = Config#config.udp_options, - UdpOptions2 = lists:keydelete(fd, 1, UdpOptions), - Config1 = Config#config{udp_options = UdpOptions2}, - Config2 = tftp_lib:parse_config(SuggestedOptions, Config1), - SuggestedOptions2 = Config2#config.user_options, - Req2 = Req#tftp_msg_req{options = SuggestedOptions2}, - case open_free_port(Config2, server, Req2) of - {ok, Config3} -> - Filename = Req#tftp_msg_req.filename, - case match_callback(Filename, Config3#config.callbacks) of - {ok, Callback} -> - print_debug_info(Config3, server, match, Callback), - case pre_verify_options(Config3, Req2) of - ok -> - case callback({open, server_open}, Config3, Callback, Req2) of - {Callback2, {ok, AcceptedOptions}} -> - {LocalAccess, _} = local_file_access(Req2), - OptText = "Internal error. Not allowed to add new options.", - case post_verify_options(Config3, Req2, AcceptedOptions, OptText) of - {ok, Config4, Req3} when AcceptedOptions /= [] -> - Reply = #tftp_msg_oack{options = AcceptedOptions}, - {Config5, Callback3, Next} = - transfer(Config4, Callback2, Req3, Reply, LocalAccess, undefined), - BlockNo = - case LocalAccess of - read -> 0; - write -> 1 - end, - common_loop(Config5, Callback3, Req3, Next, LocalAccess, BlockNo); - {ok, Config4, Req3} when LocalAccess =:= write -> - BlockNo = 0, - common_ack(Config4, Callback2, Req3, LocalAccess, BlockNo, undefined); - {ok, Config4, Req3} when LocalAccess =:= read -> - BlockNo = 0, - common_read(Config4, Callback2, Req3, LocalAccess, BlockNo, BlockNo, undefined); - {error, {Code, Text}} -> - {undefined, Error} = - callback({abort, {Code, Text}}, Config3, Callback2, Req2), - send_msg(Config3, Req, Error), - terminate(Config3, Req2, ?ERROR(post_verify_options, Code, Text)) - end; - {undefined, #tftp_msg_error{code = Code, text = Text} = Error} -> - send_msg(Config3, Req, Error), - terminate(Config3, Req, ?ERROR(server_open, Code, Text)) - end; - {error, {Code, Text}} -> - {undefined, Error} = - callback({abort, {Code, Text}}, Config2, Callback, Req2), - send_msg(Config2, Req, Error), - terminate(Config2, Req2, ?ERROR(pre_verify_options, Code, Text)) - end; - {error, #tftp_msg_error{code = Code, text = Text} = Error} -> - send_msg(Config3, Req, Error), - terminate(Config3, Req, ?ERROR(match_callback, Code, Text)) - end; - #error{} = Error -> - terminate(Config2, Req, Error) - end. - -%%%------------------------------------------------------------------- -%%% Client -%%%------------------------------------------------------------------- - -%% LocalFilename = filename() | 'binary' | binary() -%% Returns {ok, LastCallbackState} | {error, Reason} -client_start(Access, RemoteFilename, LocalFilename, Options) -> - Config = tftp_lib:parse_config(Options), - Config2 = Config#config{parent_pid = self(), - udp_socket = undefined}, - Req = #tftp_msg_req{access = Access, - filename = RemoteFilename, - mode = lookup_mode(Config2#config.user_options), - options = Config2#config.user_options, - local_filename = LocalFilename}, - Args = [Config2, Req], - case proc_lib:start_link(?MODULE, client_init, Args, infinity) of - {ok, LastCallbackState} -> - {ok, LastCallbackState}; - {error, Error} -> - {error, Error} - end. - -client_init(Config, Req) when is_record(Config, config), - is_pid(Config#config.parent_pid), - is_record(Req, tftp_msg_req) -> - process_flag(trap_exit, true), - case open_free_port(Config, client, Req) of - {ok, Config2} -> - Req2 = - case Config2#config.use_tsize of - true -> - SuggestedOptions = Req#tftp_msg_req.options, - SuggestedOptions2 = tftp_lib:replace_val("tsize", "0", SuggestedOptions), - Req#tftp_msg_req{options = SuggestedOptions2}; - false -> - Req - end, - LocalFilename = Req2#tftp_msg_req.local_filename, - case match_callback(LocalFilename, Config2#config.callbacks) of - {ok, Callback} -> - print_debug_info(Config2, client, match, Callback), - client_prepare(Config2, Callback, Req2); - {error, #tftp_msg_error{code = Code, text = Text}} -> - terminate(Config, Req, ?ERROR(match, Code, Text)) - end; - #error{} = Error -> - terminate(Config, Req, Error) - end. - -client_prepare(Config, Callback, Req) -> - case pre_verify_options(Config, Req) of - ok -> - case callback({open, client_prepare}, Config, Callback, Req) of - {Callback2, {ok, AcceptedOptions}} -> - OptText = "Internal error. Not allowed to add new options.", - case post_verify_options(Config, Req, AcceptedOptions, OptText) of - {ok, Config2, Req2} -> - {LocalAccess, _} = local_file_access(Req2), - {Config3, Callback3, Next} = - transfer(Config2, Callback2, Req2, Req2, LocalAccess, undefined), - client_open(Config3, Callback3, Req2, Next); - {error, {Code, Text}} -> - callback({abort, {Code, Text}}, Config, Callback2, Req), - terminate(Config, Req, ?ERROR(post_verify_options, Code, Text)) - end; - {undefined, #tftp_msg_error{code = Code, text = Text}} -> - terminate(Config, Req, ?ERROR(client_prepare, Code, Text)) - end; - {error, {Code, Text}} -> - callback({abort, {Code, Text}}, Config, Callback, Req), - terminate(Config, Req, ?ERROR(pre_verify_options, Code, Text)) - end. - -client_open(Config, Callback, Req, Next) -> - {LocalAccess, _} = local_file_access(Req), - case Next of - {ok, DecodedMsg, undefined} -> - case DecodedMsg of - Msg when record(Msg, tftp_msg_oack) -> - ServerOptions = Msg#tftp_msg_oack.options, - OptText = "Protocol violation. Server is not allowed new options", - case post_verify_options(Config, Req, ServerOptions, OptText) of - {ok, Config2, Req2} -> - {Config3, Callback2, Req3} = - do_client_open(Config2, Callback, Req2), - case LocalAccess of - read -> - BlockNo = 0, - common_read(Config3, Callback2, Req3, LocalAccess, BlockNo, BlockNo, undefined); - write -> - BlockNo = 0, - common_ack(Config3, Callback2, Req3, LocalAccess, BlockNo, undefined) - end; - {error, {Code, Text}} -> - {undefined, Error} = - callback({abort, {Code, Text}}, Config, Callback, Req), - send_msg(Config, Req, Error), - terminate(Config, Req, ?ERROR(verify_server_options, Code, Text)) - end; - #tftp_msg_ack{block_no = ActualBlockNo} when LocalAccess =:= read -> - Req2 = Req#tftp_msg_req{options = []}, - {Config2, Callback2, Req2} = do_client_open(Config, Callback, Req2), - ExpectedBlockNo = 0, - common_read(Config2, Callback2, Req2, LocalAccess, ExpectedBlockNo, ActualBlockNo, undefined); - #tftp_msg_data{block_no = ActualBlockNo, data = Data} when LocalAccess =:= write -> - Req2 = Req#tftp_msg_req{options = []}, - {Config2, Callback2, Req2} = do_client_open(Config, Callback, Req2), - ExpectedBlockNo = 1, - common_write(Config2, Callback2, Req2, LocalAccess, ExpectedBlockNo, ActualBlockNo, Data, undefined); - %% #tftp_msg_error{code = Code, text = Text} when Req#tftp_msg_req.options /= [] -> - %% %% Retry without options - %% callback({abort, {Code, Text}}, Config, Callback, Req), - %% Req2 = Req#tftp_msg_req{options = []}, - %% client_prepare(Config, Callback, Req2); - #tftp_msg_error{code = Code, text = Text} -> - callback({abort, {Code, Text}}, Config, Callback, Req), - terminate(Config, Req, ?ERROR(client_open, Code, Text)); - {'EXIT', #tftp_msg_error{code = Code, text = Text}} -> - callback({abort, {Code, Text}}, Config, Callback, Req), - terminate(Config, Req, ?ERROR(client_open, Code, Text)); - Msg when is_tuple(Msg) -> - Code = badop, - Text = "Illegal TFTP operation", - {undefined, Error} = - callback({abort, {Code, Text}}, Config, Callback, Req), - send_msg(Config, Req, Error), - Text2 = lists:flatten([Text, ". ", io_lib:format("~p", [element(1, Msg)])]), - terminate(Config, Req, ?ERROR(client_open, Code, Text2)) - end; - {error, #tftp_msg_error{code = Code, text = Text}} -> - callback({abort, {Code, Text}}, Config, Callback, Req), - terminate(Config, Req, ?ERROR(client_open, Code, Text)) - end. - -do_client_open(Config, Callback, Req) -> - case callback({open, client_open}, Config, Callback, Req) of - {Callback2, {ok, FinalOptions}} -> - OptText = "Internal error. Not allowed to change options.", - case post_verify_options(Config, Req, FinalOptions, OptText) of - {ok, Config2, Req2} -> - {Config2, Callback2, Req2}; - {error, {Code, Text}} -> - {undefined, Error} = - callback({abort, {Code, Text}}, Config, Callback, Req), - send_msg(Config, Req, Error), - terminate(Config, Req, ?ERROR(post_verify_options, Code, Text)) - end; - {undefined, #tftp_msg_error{code = Code, text = Text} = Error} -> - send_msg(Config, Req, Error), - terminate(Config, Req, ?ERROR(client_open, Code, Text)) - end. - -%%%------------------------------------------------------------------- -%%% Common loop for both client and server -%%%------------------------------------------------------------------- - -common_loop(Config, Callback, Req, Next, LocalAccess, ExpectedBlockNo) -> - case Next of - {ok, DecodedMsg, Prepared} -> - case DecodedMsg of - #tftp_msg_ack{block_no = ActualBlockNo} when LocalAccess =:= read -> - common_read(Config, Callback, Req, LocalAccess, ExpectedBlockNo, ActualBlockNo, Prepared); - #tftp_msg_data{block_no = ActualBlockNo, data = Data} when LocalAccess =:= write -> - common_write(Config, Callback, Req, LocalAccess, ExpectedBlockNo, ActualBlockNo, Data, Prepared); - #tftp_msg_error{code = Code, text = Text} -> - callback({abort, {Code, Text}}, Config, Callback, Req), - terminate(Config, Req, ?ERROR(common_loop, Code, Text)); - {'EXIT', #tftp_msg_error{code = Code, text = Text} = Error} -> - callback({abort, {Code, Text}}, Config, Callback, Req), - send_msg(Config, Req, Error), - terminate(Config, Req, ?ERROR(common_loop, Code, Text)); - Msg when is_tuple(Msg) -> - Code = badop, - Text = "Illegal TFTP operation", - {undefined, Error} = - callback({abort, {Code, Text}}, Config, Callback, Req), - send_msg(Config, Req, Error), - Text2 = lists:flatten([Text, ". ", io_lib:format("~p", [element(1, Msg)])]), - terminate(Config, Req, ?ERROR(common_loop, Code, Text2)) - end; - {error, #tftp_msg_error{code = Code, text = Text} = Error} -> - send_msg(Config, Req, Error), - terminate(Config, Req, ?ERROR(transfer, Code, Text)) - end. - -common_read(Config, _, Req, _, _, _, {terminate, Result}) -> - terminate(Config, Req, {ok, Result}); -common_read(Config, Callback, Req, LocalAccess, BlockNo, BlockNo, Prepared) -> - case early_read(Config, Callback, Req, LocalAccess, Prepared) of - {Callback2, {more, Data}} -> - do_common_read(Config, Callback2, Req, LocalAccess, BlockNo, Data, undefined); - {undefined, {last, Data, Result}} -> - do_common_read(Config, undefined, Req, LocalAccess, BlockNo, Data, {terminate, Result}); - {undefined, #tftp_msg_error{code = Code, text = Text} = Reply} -> - send_msg(Config, Req, Reply), - terminate(Config, Req, ?ERROR(read, Code, Text)) - end; -common_read(Config, Callback, Req, LocalAccess, ExpectedBlockNo, ActualBlockNo, Prepared) - when ActualBlockNo < ExpectedBlockNo -> - do_common_read(Config, Callback, Req, LocalAccess, ExpectedBlockNo - 1, Prepared, undefined); -common_read(Config, Callback, Req, _LocalAccess, ExpectedBlockNo, ActualBlockNo, _Prepared) -> - Code = badblk, - Text = "Unknown transfer ID = " ++ - integer_to_list(ActualBlockNo) ++ " (" ++ integer_to_list(ExpectedBlockNo) ++ ")", - {undefined, Error} = - callback({abort, {Code, Text}}, Config, Callback, Req), - send_msg(Config, Req, Error), - terminate(Config, Req, ?ERROR(read, Code, Text)). - -do_common_read(Config, Callback, Req, LocalAccess, BlockNo, Data, Prepared) -> - NextBlockNo = BlockNo + 1, - case NextBlockNo =< 65535 of - true -> - Reply = #tftp_msg_data{block_no = NextBlockNo, data = Data}, - {Config2, Callback2, Next} = - transfer(Config, Callback, Req, Reply, LocalAccess, Prepared), - common_loop(Config2, Callback2, Req, Next, LocalAccess, NextBlockNo); - false -> - Code = badblk, - Text = "Too big transfer ID = " ++ - integer_to_list(NextBlockNo) ++ " > 65535", - {undefined, Error} = - callback({abort, {Code, Text}}, Config, Callback, Req), - send_msg(Config, Req, Error), - terminate(Config, Req, ?ERROR(read, Code, Text)) - end. - -common_write(Config, _, Req, _, _, _, _, {terminate, Result}) -> - terminate(Config, Req, {ok, Result}); -common_write(Config, Callback, Req, LocalAccess, BlockNo, BlockNo, Data, undefined) -> - case callback({write, Data}, Config, Callback, Req) of - {Callback2, more} -> - common_ack(Config, Callback2, Req, LocalAccess, BlockNo, undefined); - {undefined, {last, Result}} -> - Config2 = pre_terminate(Config, Req, {ok, Result}), - common_ack(Config2, undefined, Req, LocalAccess, BlockNo, {terminate, Result}); - {undefined, #tftp_msg_error{code = Code, text = Text} = Reply} -> - send_msg(Config, Req, Reply), - terminate(Config, Req, ?ERROR(write, Code, Text)) - end; -common_write(Config, Callback, Req, LocalAccess, ExpectedBlockNo, ActualBlockNo, _Data, undefined) - when ActualBlockNo < ExpectedBlockNo -> - common_ack(Config, Callback, Req, LocalAccess, ExpectedBlockNo - 1, undefined); -common_write(Config, Callback, Req, _, ExpectedBlockNo, ActualBlockNo, _, _) -> - Code = badblk, - Text = "Unknown transfer ID = " ++ - integer_to_list(ActualBlockNo) ++ " (" ++ integer_to_list(ExpectedBlockNo) ++ ")", - {undefined, Error} = - callback({abort, {Code, Text}}, Config, Callback, Req), - send_msg(Config, Req, Error), - terminate(Config, Req, ?ERROR(write, Code, Text)). - -common_ack(Config, Callback, Req, LocalAccess, BlockNo, Prepared) -> - Reply = #tftp_msg_ack{block_no = BlockNo}, - {Config2, Callback2, Next} = - transfer(Config, Callback, Req, Reply, LocalAccess, Prepared), - NextBlockNo = BlockNo + 1, - case NextBlockNo =< 65535 of - true -> - common_loop(Config2, Callback2, Req, Next, LocalAccess, NextBlockNo); - false -> - Code = badblk, - Text = "Too big transfer ID = " ++ - integer_to_list(NextBlockNo) ++ " > 65535", - {undefined, Error} = - callback({abort, {Code, Text}}, Config, Callback, Req), - send_msg(Config, Req, Error), - terminate(Config, Req, ?ERROR(read, Code, Text)) - end. - -pre_terminate(Config, Req, Result) -> - if - Req#tftp_msg_req.local_filename /= undefined, - Config#config.parent_pid /= undefined -> - proc_lib:init_ack(Result), - unlink(Config#config.parent_pid), - Config#config{parent_pid = undefined, polite_ack = true}; - true -> - Config#config{polite_ack = true} - end. - -terminate(Config, Req, Result) -> - Result2 = - case Result of - {ok, _} -> - Result; - #error{what = What, code = Code, text = Text} = Error -> - print_debug_info(Config, Req, What, Error), - {error, {What, Code, Text}} - end, - if - Config#config.parent_pid =:= undefined -> - close_port(Config, client, Req), - exit(normal); - Req#tftp_msg_req.local_filename /= undefined -> - %% Client - close_port(Config, client, Req), - proc_lib:init_ack(Result2), - unlink(Config#config.parent_pid), - exit(normal); - true -> - %% Server - close_port(Config, server, Req), - exit(shutdown) - end. - -close_port(Config, Who, Data) -> - case Config#config.udp_socket of - undefined -> - ignore; - Socket -> - print_debug_info(Config, Who, close, Data), - gen_udp:close(Socket) - end. - -open_free_port(Config, Who, Data) when is_record(Config, config) -> - UdpOptions = Config#config.udp_options, - case Config#config.port_policy of - random -> - %% BUGBUG: Should be a random port - case catch gen_udp:open(0, UdpOptions) of - {ok, Socket} -> - Config2 = Config#config{udp_socket = Socket}, - print_debug_info(Config2, Who, open, Data), - {ok, Config2}; - {error, Reason} -> - Text = lists:flatten(io_lib:format("UDP open ~p -> ~p", [[0 | UdpOptions], Reason])), - ?ERROR(open, undef, Text); - {'EXIT', _} = Reason -> - Text = lists:flatten(io_lib:format("UDP open ~p -> ~p", [[0 | UdpOptions], Reason])), - ?ERROR(open, undef, Text) - end; - {range, Port, Max} when Port =< Max -> - case catch gen_udp:open(Port, UdpOptions) of - {ok, Socket} -> - Config2 = Config#config{udp_socket = Socket}, - print_debug_info(Config2, Who, open, Data), - {ok, Config2}; - {error, eaddrinuse} -> - PortPolicy = {range, Port + 1, Max}, - Config2 = Config#config{port_policy = PortPolicy}, - open_free_port(Config2, Who, Data); - {error, Reason} -> - Text = lists:flatten(io_lib:format("UDP open ~p -> ~p", [[Port | UdpOptions], Reason])), - ?ERROR(open, undef, Text); - {'EXIT', _} = Reason-> - Text = lists:flatten(io_lib:format("UDP open ~p -> ~p", [[Port | UdpOptions], Reason])), - ?ERROR(open, undef, Text) - end; - {range, Port, _Max} -> - Reason = "Port range exhausted", - Text = lists:flatten(io_lib:format("UDP open ~p -> ~p", [[Port | UdpOptions], Reason])), - ?ERROR(Who, undef, Text) - end. - -%%------------------------------------------------------------------- -%% Transfer -%%------------------------------------------------------------------- - -%% Returns {Config, Callback, Next} -%% Next = {ok, Reply, Next} | {error, Error} -transfer(Config, Callback, Req, Msg, LocalAccess, Prepared) -> - IoList = tftp_lib:encode_msg(Msg), - do_transfer(Config, Callback, Req, Msg, IoList, LocalAccess, Prepared, true). - -do_transfer(Config, Callback, Req, Msg, IoList, LocalAccess, Prepared, Retry) -> - case do_send_msg(Config, Req, Msg, IoList) of - ok -> - {Callback2, Prepared2} = - early_read(Config, Callback, Req, LocalAccess, Prepared), - Code = undef, - Text = "Transfer timed out.", - case wait_for_msg(Config, Callback, Req) of - timeout when Config#config.polite_ack =:= true -> - do_send_msg(Config, Req, Msg, IoList), - case Prepared2 of - {terminate, Result} -> - terminate(Config, Req, {ok, Result}); - _ -> - terminate(Config, Req, ?ERROR(transfer, Code, Text)) - end; - timeout when Retry =:= true -> - Retry2 = false, - do_transfer(Config, Callback2, Req, Msg, IoList, LocalAccess, Prepared2, Retry2); - timeout -> - Error = #tftp_msg_error{code = Code, text = Text}, - {Config, Callback, {error, Error}}; - {Config2, Reply} -> - {Config2, Callback2, {ok, Reply, Prepared2}} - end; - {error, _Reason} when Retry =:= true -> - do_transfer(Config, Callback, Req, Msg, IoList, LocalAccess, Prepared, false); - {error, Reason} -> - Code = undef, - Text = lists:flatten(io_lib:format("Transfer failed twice - giving up -> ~p", [Reason])), - {Config, Callback, {error, #tftp_msg_error{code = Code, text = Text}}} - end. - -send_msg(Config, Req, Msg) -> - case catch tftp_lib:encode_msg(Msg) of - {'EXIT', Reason} -> - Code = undef, - Text = "Internal error. Encode failed", - Msg2 = #tftp_msg_error{code = Code, text = Text, details = Reason}, - send_msg(Config, Req, Msg2); - IoList -> - do_send_msg(Config, Req, Msg, IoList) - end. - -do_send_msg(Config, Req, Msg, IoList) -> - print_debug_info(Config, Req, send, Msg), - gen_udp:send(Config#config.udp_socket, - Config#config.udp_host, - Config#config.udp_port, - IoList). - -wait_for_msg(Config, Callback, Req) -> - receive - {info, Ref, FromPid} when is_pid(FromPid) -> - Type = - case Req#tftp_msg_req.local_filename /= undefined of - true -> client; - false -> server - end, - Info = internal_info(Config, Type), - reply({ok, Info}, Ref, FromPid), - wait_for_msg(Config, Callback, Req); - {{change_config, Options}, Ref, FromPid} when is_pid(FromPid) -> - case catch tftp_lib:parse_config(Options, Config) of - {'EXIT', Reason} -> - reply({error, Reason}, Ref, FromPid), - wait_for_msg(Config, Callback, Req); - Config2 when is_record(Config2, config) -> - reply(ok, Ref, FromPid), - wait_for_msg(Config2, Callback, Req) - end; - {udp, Socket, RemoteHost, RemotePort, Bin} when is_binary(Bin), - Callback#callback.block_no =:= undefined -> - %% Client prepare - inet:setopts(Socket, [{active, once}]), - Config2 = Config#config{udp_host = RemoteHost, - udp_port = RemotePort}, - DecodedMsg = (catch tftp_lib:decode_msg(Bin)), - print_debug_info(Config2, Req, recv, DecodedMsg), - {Config2, DecodedMsg}; - {udp, Socket, Host, Port, Bin} when is_binary(Bin), - Config#config.udp_host =:= Host, - Config#config.udp_port =:= Port -> - inet:setopts(Socket, [{active, once}]), - DecodedMsg = (catch tftp_lib:decode_msg(Bin)), - print_debug_info(Config, Req, recv, DecodedMsg), - {Config, DecodedMsg}; - {system, From, Msg} -> - Misc = {wait_for_msg, [Config, Callback, Req]}, - sys:handle_system_msg(Msg, From, Config#config.parent_pid, ?MODULE, [], Misc); - {'EXIT', Pid, _Reason} when Config#config.parent_pid =:= Pid -> - Code = undef, - Text = "Parent exited.", - terminate(Config, Req, ?ERROR(wait_for_msg, Code, Text)); - Msg when Req#tftp_msg_req.local_filename /= undefined -> - error("Client received : ~p", [Msg]), - wait_for_msg(Config, Callback, Req); - Msg when Req#tftp_msg_req.local_filename =:= undefined -> - error("Server received : ~p", [Msg]), - wait_for_msg(Config, Callback, Req) - after Config#config.timeout * 1000 -> - print_debug_info(Config, Req, recv, timeout), - timeout - end. - -early_read(Config, Callback, Req, read, undefined) - when Callback#callback.block_no /= undefined -> - callback(read, Config, Callback, Req); -early_read(_Config, Callback, _Req, _LocalAccess, Prepared) -> - {Callback, Prepared}. - -%%------------------------------------------------------------------- -%% Callback -%%------------------------------------------------------------------- - -callback(Access, Config, Callback, Req) -> - {Callback2, Result} = - do_callback(Access, Config, Callback, Req), - print_debug_info(Config, Req, call, {Callback2, Result}), - {Callback2, Result}. - -do_callback(read = Fun, Config, Callback, Req) - when is_record(Config, config), - is_record(Callback, callback), - is_record(Req, tftp_msg_req) -> - Args = [Callback#callback.state], - case catch apply(Callback#callback.module, Fun, Args) of - {more, Bin, NewState} when is_binary(Bin) -> - BlockNo = Callback#callback.block_no + 1, - Count = Callback#callback.count + size(Bin), - Callback2 = Callback#callback{state = NewState, - block_no = BlockNo, - count = Count}, - verify_count(Config, Callback2, Req, {more, Bin}); - {last, Data, Result} -> - {undefined, {last, Data, Result}}; - {error, {Code, Text}} -> - {undefined, #tftp_msg_error{code = Code, text = Text}}; - Details -> - Code = undef, - Text = "Internal error. File handler error.", - callback({abort, {Code, Text, Details}}, Config, Callback, Req) - end; -do_callback({write = Fun, Bin}, Config, Callback, Req) - when is_record(Config, config), - is_record(Callback, callback), - is_record(Req, tftp_msg_req), - is_binary(Bin) -> - Args = [Bin, Callback#callback.state], - case catch apply(Callback#callback.module, Fun, Args) of - {more, NewState} -> - BlockNo = Callback#callback.block_no + 1, - Count = Callback#callback.count + size(Bin), - Callback2 = Callback#callback{state = NewState, - block_no = BlockNo, - count = Count}, - verify_count(Config, Callback2, Req, more); - {last, Result} -> - {undefined, {last, Result}}; - {error, {Code, Text}} -> - {undefined, #tftp_msg_error{code = Code, text = Text}}; - Details -> - Code = undef, - Text = "Internal error. File handler error.", - callback({abort, {Code, Text, Details}}, Config, Callback, Req) - end; -do_callback({open, Type}, Config, Callback, Req) - when is_record(Config, config), - is_record(Callback, callback), - is_record(Req, tftp_msg_req) -> - {Access, Filename} = local_file_access(Req), - {Fun, BlockNo} = - case Type of - client_prepare -> {prepare, undefined}; - client_open -> {open, 0}; - server_open -> {open, 0} - end, - Mod = Callback#callback.module, - Args = [Access, - Filename, - Req#tftp_msg_req.mode, - Req#tftp_msg_req.options, - Callback#callback.state], - PeerInfo = peer_info(Config), - code:ensure_loaded(Mod), - Args2 = - case erlang:function_exported(Mod, Fun, length(Args)) of - true -> Args; - false -> [PeerInfo | Args] - end, - case catch apply(Mod, Fun, Args2) of - {ok, AcceptedOptions, NewState} -> - Callback2 = Callback#callback{state = NewState, - block_no = BlockNo, - count = 0}, - {Callback2, {ok, AcceptedOptions}}; - {error, {Code, Text}} -> - {undefined, #tftp_msg_error{code = Code, text = Text}}; - Details -> - Code = undef, - Text = "Internal error. File handler error.", - callback({abort, {Code, Text, Details}}, Config, Callback, Req) - end; -do_callback({abort, {Code, Text}}, Config, Callback, Req) -> - Error = #tftp_msg_error{code = Code, text = Text}, - do_callback({abort, Error}, Config, Callback, Req); -do_callback({abort, {Code, Text, Details}}, Config, Callback, Req) -> - Error = #tftp_msg_error{code = Code, text = Text, details = Details}, - do_callback({abort, Error}, Config, Callback, Req); -do_callback({abort = Fun, #tftp_msg_error{code = Code, text = Text} = Error}, Config, Callback, Req) - when is_record(Config, config), - is_record(Callback, callback), - is_record(Req, tftp_msg_req) -> - Args = [Code, Text, Callback#callback.state], - catch apply(Callback#callback.module, Fun, Args), - {undefined, Error}; -do_callback({abort, Error}, _Config, undefined, _Req) when is_record(Error, tftp_msg_error) -> - {undefined, Error}. - -peer_info(#config{udp_host = Host, udp_port = Port}) -> - if - is_tuple(Host), size(Host) =:= 4 -> - {inet, tftp_lib:host_to_string(Host), Port}; - is_tuple(Host), size(Host) =:= 8 -> - {inet6, tftp_lib:host_to_string(Host), Port}; - true -> - {undefined, Host, Port} - end. - -match_callback(Filename, Callbacks) -> - if - Filename =:= binary -> - {ok, #callback{regexp = "", - internal = "", - module = tftp_binary, - state = []}}; - is_binary(Filename) -> - {ok, #callback{regexp = "", - internal = "", - module = tftp_binary, - state = []}}; - Callbacks =:= [] -> - {ok, #callback{regexp = "", - internal = "", - module = tftp_file, - state = []}}; - true -> - do_match_callback(Filename, Callbacks) - end. - -do_match_callback(Filename, [C | Tail]) when is_record(C, callback) -> - case catch regexp:match(Filename, C#callback.internal) of - {match, _, _} -> - {ok, C}; - nomatch -> - do_match_callback(Filename, Tail); - Details -> - Code = baduser, - Text = "Internal error. File handler not found", - {error, #tftp_msg_error{code = Code, text = Text, details = Details}} - end; -do_match_callback(Filename, []) -> - Code = baduser, - Text = "Internal error. File handler not found", - {error, #tftp_msg_error{code = Code, text = Text, details = Filename}}. - -verify_count(Config, Callback, Req, Result) -> - case Config#config.max_tsize of - infinity -> - {Callback, Result}; - Max when Callback#callback.count =< Max -> - {Callback, Result}; - _Max -> - Code = enospc, - Text = "Too large file.", - callback({abort, {Code, Text}}, Config, Callback, Req) - end. - -%%------------------------------------------------------------------- -%% Miscellaneous -%%------------------------------------------------------------------- - -internal_info(Config, Type) -> - {ok, ActualPort} = inet:port(Config#config.udp_socket), - [ - {type, Type}, - {host, tftp_lib:host_to_string(Config#config.udp_host)}, - {port, Config#config.udp_port}, - {local_port, ActualPort}, - {port_policy, Config#config.port_policy}, - {udp, Config#config.udp_options}, - {use_tsize, Config#config.use_tsize}, - {max_tsize, Config#config.max_tsize}, - {max_conn, Config#config.max_conn}, - {rejected, Config#config.rejected}, - {timeout, Config#config.timeout}, - {polite_ack, Config#config.polite_ack}, - {debug, Config#config.debug_level}, - {parent_pid, Config#config.parent_pid} - ] ++ Config#config.user_options ++ Config#config.callbacks. - -local_file_access(#tftp_msg_req{access = Access, - local_filename = Local, - filename = Filename}) -> - case Local =:= undefined of - true -> - %% Server side - {Access, Filename}; - false -> - %% Client side - case Access of - read -> - {write, Local}; - write -> - {read, Local} - end - end. - -pre_verify_options(Config, Req) -> - Options = Req#tftp_msg_req.options, - case catch verify_reject(Config, Req, Options) of - ok -> - case verify_integer("tsize", 0, Config#config.max_tsize, Options) of - true -> - case verify_integer("blksize", 0, 65464, Options) of - true -> - ok; - false -> - {error, {badopt, "Too large blksize"}} - end; - false -> - {error, {badopt, "Too large tsize"}} - end; - {error, Reason} -> - {error, Reason} - end. - -post_verify_options(Config, Req, NewOptions, Text) -> - OldOptions = Req#tftp_msg_req.options, - BadOptions = - [Key || {Key, _Val} <- NewOptions, - not lists:keymember(Key, 1, OldOptions)], - case BadOptions =:= [] of - true -> - {ok, - Config#config{timeout = lookup_timeout(NewOptions)}, - Req#tftp_msg_req{options = NewOptions}}; - false -> - {error, {badopt, Text}} - end. - -verify_reject(Config, Req, Options) -> - Access = Req#tftp_msg_req.access, - Rejected = Config#config.rejected, - case lists:member(Access, Rejected) of - true -> - {error, {eacces, atom_to_list(Access) ++ " mode not allowed"}}; - false -> - [throw({error, {badopt, Key ++ " not allowed"}}) || - {Key, _} <- Options, lists:member(Key, Rejected)], - ok - end. - -lookup_timeout(Options) -> - case lists:keysearch("timeout", 1, Options) of - {value, {_, Val}} -> - list_to_integer(Val); - false -> - 3 - end. - -lookup_mode(Options) -> - case lists:keysearch("mode", 1, Options) of - {value, {_, Val}} -> - Val; - false -> - "octet" - end. - -verify_integer(Key, Min, Max, Options) -> - case lists:keysearch(Key, 1, Options) of - {value, {_, Val}} when is_list(Val) -> - case catch list_to_integer(Val) of - {'EXIT', _} -> - false; - Int when Int >= Min, is_integer(Min), - Max =:= infinity -> - true; - Int when Int >= Min, is_integer(Min), - Int =< Max, is_integer(Max) -> - true; - _ -> - false - end; - false -> - true - end. -error(F, A) -> - ok = error_logger:format("~p(~p): " ++ F ++ "~n", [?MODULE, self() | A]). - -print_debug_info(#config{debug_level = Level} = Config, Who, What, Data) -> - if - Level =:= none -> - ok; - is_record(Data, error) -> - do_print_debug_info(Config, Who, What, Data); - Level =:= error -> - ok; - Level =:= all -> - do_print_debug_info(Config, Who, What, Data); - What =:= open -> - do_print_debug_info(Config, Who, What, Data); - What =:= close -> - do_print_debug_info(Config, Who, What, Data); - Level =:= brief -> - ok; - What /= recv, What /= send -> - ok; - is_record(Data, tftp_msg_data), Level =:= normal -> - ok; - is_record(Data, tftp_msg_ack), Level =:= normal -> - ok; - true -> - do_print_debug_info(Config, Who, What, Data) - end. - -do_print_debug_info(Config, Who, What, #tftp_msg_data{data = Bin} = Msg) when is_binary(Bin) -> - Msg2 = Msg#tftp_msg_data{data = {bytes, size(Bin)}}, - do_print_debug_info(Config, Who, What, Msg2); -do_print_debug_info(Config, Who, What, #tftp_msg_req{local_filename = Filename} = Msg) when is_binary(Filename) -> - Msg2 = Msg#tftp_msg_req{local_filename = binary}, - do_print_debug_info(Config, Who, What, Msg2); -do_print_debug_info(Config, Who, What, Data) -> - Local = - case catch inet:port(Config#config.udp_socket) of - {'EXIT', _Reason} -> - 0; - {ok, Port} -> - Port - end, - %% Remote = Config#config.udp_port, - PeerInfo = peer_info(Config), - Side = - if - is_record(Who, tftp_msg_req), - Who#tftp_msg_req.local_filename /= undefined -> - client; - is_record(Who, tftp_msg_req), - Who#tftp_msg_req.local_filename =:= undefined -> - server; - is_atom(Who) -> - Who - end, - case {What, Data} of - {_, #error{what = What, code = Code, text = Text}} -> - io:format("~p(~p): ~p ~p -> ~p: ~s\n", [Side, Local, self(), What, Code, Text]); - {open, #tftp_msg_req{filename = Filename}} -> - io:format("~p(~p): open ~p -> ~p ~p\n", [Side, Local, PeerInfo, self(), Filename]); - {close, #tftp_msg_req{filename = Filename}} -> - io:format("~p(~p): close ~p -> ~p ~p\n", [Side, Local, PeerInfo, self(), Filename]); - {recv, _} -> - io:format("~p(~p): recv ~p <- ~p\n", [Side, Local, PeerInfo, Data]); - {send, _} -> - io:format("~p(~p): send ~p -> ~p\n", [Side, Local, PeerInfo, Data]); - {match, _} when is_record(Data, callback) -> - Mod = Data#callback.module, - State = Data#callback.state, - io:format("~p(~p): match ~p ~p => ~p\n", [Side, Local, PeerInfo, Mod, State]); - {call, _} -> - case Data of - {Callback, _Result} when is_record(Callback, callback) -> - Mod = Callback#callback.module, - State = Callback#callback.state, - io:format("~p(~p): call ~p ~p => ~p\n", [Side, Local, PeerInfo, Mod, State]); - {undefined, Result} -> - io:format("~p(~p): call ~p result => ~p\n", [Side, Local, PeerInfo, Result]) - end - end. - - -%%------------------------------------------------------------------- -%% System upgrade -%%------------------------------------------------------------------- - -system_continue(_Parent, _Debug, {Fun, Args}) -> - apply(?MODULE, Fun, Args). - -system_terminate(Reason, _Parent, _Debug, {_Fun, _Args}) -> - exit(Reason). - -system_code_change({Fun, Args}, _Module, _OldVsn, _Extra) -> - {ok, {Fun, Args}}. diff --git a/src/couch_inets/tftp_file.erl b/src/couch_inets/tftp_file.erl deleted file mode 100644 index 03e54047..00000000 --- a/src/couch_inets/tftp_file.erl +++ /dev/null @@ -1,338 +0,0 @@ -%%%------------------------------------------------------------------- -%%% File : tft_file.erl -%%% Author : Hakan Mattsson <hakan@erix.ericsson.se> -%%% Description : -%%% -%%% Created : 24 May 2004 by Hakan Mattsson <hakan@erix.ericsson.se> -%%%------------------------------------------------------------------- - --module(tftp_file). - -%%%------------------------------------------------------------------- -%%% Interface -%%%------------------------------------------------------------------- - --behaviour(tftp). - --export([prepare/6, open/6, read/1, write/2, abort/3]). --export([prepare/5, open/5]). - -%%%------------------------------------------------------------------- -%%% Defines -%%%------------------------------------------------------------------- - --include_lib("kernel/include/file.hrl"). - --record(state, {access, - filename, - root_dir, - options, - blksize, - fd, - count, - buffer}). - -%%------------------------------------------------------------------- -%% prepare(Peer, Access, Filename, Mode, SuggestedOptions, InitialState) -> -%% {ok, AcceptedOptions, NewState} | {error, Code, Text} -%% -%% Peer = {PeerType, PeerHost, PeerPort} -%% PeerType = inet | inet6 -%% PeerHost = ip_address() -%% PeerPort = integer() -%% Acess = read | write -%% Filename = string() -%% Mode = string() -%% SuggestedOptions = [{Key, Value}] -%% AcceptedOptions = [{Key, Value}] -%% Key = string() -%% Value = string() -%% InitialState = [] | [{root_dir, string()}] -%% NewState = term() -%% Code = undef | enoent | eacces | enospc | -%% badop | eexist | baduser | badopt | -%% integer() -%% Text = string() -%% -%% Prepares open of a file on the client side. -%% -%% Will be followed by a call to open/4 before any read/write access -%% is performed. The AcceptedOptions will be sent to the server which -%% will reply with those options that it accepts. The options that are -%% accepted by the server will be forwarded to open/4 as SuggestedOptions. -%% -%% No new options may be added, but the ones that are present as -%% SuggestedOptions may be omitted or replaced with new values -%% in the AcceptedOptions. -%%------------------------------------------------------------------- - -prepare(_Peer, Access, Filename, Mode, SuggestedOptions, Initial) -> - %% Kept for backwards compatibility - prepare(Access, Filename, Mode, SuggestedOptions, Initial). - -prepare(Access, Filename, Mode, SuggestedOptions, Initial) when is_list(Initial) -> - %% Client side - case catch handle_options(Access, Filename, Mode, SuggestedOptions, Initial) of - {ok, Filename2, AcceptedOptions} -> - State = #state{access = Access, - filename = Filename2, - options = AcceptedOptions, - blksize = lookup_blksize(AcceptedOptions), - count = 0, - buffer = []}, - {ok, AcceptedOptions, State}; - {error, {Code, Text}} -> - {error, {Code, Text}} - end. - -%% --------------------------------------------------------- -%% open(Peer, Access, Filename, Mode, SuggestedOptions, State) -> -%% {ok, AcceptedOptions, NewState} | {error, Code, Text} -%% -%% Peer = {PeerType, PeerHost, PeerPort} -%% PeerType = inet | inet6 -%% PeerHost = ip_address() -%% PeerPort = integer() -%% Acess = read | write -%% Filename = string() -%% Mode = string() -%% SuggestedOptions = [{Key, Value}] -%% AcceptedOptions = [{Key, Value}] -%% Key = string() -%% Value = string() -%% State = InitialState | #state{} -%% InitialState = [] | [{root_dir, string()}] -%% NewState = term() -%% Code = undef | enoent | eacces | enospc | -%% badop | eexist | baduser | badopt | -%% integer() -%% Text = string() -%% -%% Opens a file for read or write access. -%% -%% On the client side where the open/4 call has been preceeded by a -%% call to prepare/4, all options must be accepted or rejected. -%% On the server side, where there are no preceeding prepare/4 call, -%% noo new options may be added, but the ones that are present as -%% SuggestedOptions may be omitted or replaced with new values -%% in the AcceptedOptions. -%%------------------------------------------------------------------- - -open(_Peer, Access, Filename, Mode, SuggestedOptions, Initial) -> - %% Kept for backwards compatibility - open(Access, Filename, Mode, SuggestedOptions, Initial). - -open(Access, Filename, Mode, SuggestedOptions, Initial) when is_list(Initial) -> - %% Server side - case prepare(Access, Filename, Mode, SuggestedOptions, Initial) of - {ok, AcceptedOptions, State} -> - open(Access, Filename, Mode, AcceptedOptions, State); - {error, {Code, Text}} -> - {error, {Code, Text}} - end; -open(Access, Filename, Mode, NegotiatedOptions, State) when is_record(State, state) -> - %% Both sides - case catch handle_options(Access, Filename, Mode, NegotiatedOptions, State) of - {ok, _Filename2, Options} - when Options =:= NegotiatedOptions -> - do_open(State); - {error, {Code, Text}} -> - {error, {Code, Text}} - end. - -do_open(State) when is_record(State, state) -> - case file:open(State#state.filename, file_options(State)) of - {ok, Fd} -> - {ok, State#state.options, State#state{fd = Fd}}; - {error, Reason} when is_atom(Reason) -> - {error, file_error(Reason)} - end. - -file_options(State) -> - case State#state.access of - read -> [read, read_ahead, raw, binary]; - write -> [write, delayed_write, raw, binary] - end. - -file_error(Reason) when is_atom(Reason) -> - Details = file:format_error(Reason), - case Reason of - eexist -> {Reason, Details}; - enoent -> {Reason, Details}; - eacces -> {Reason, Details}; - eperm -> {eacces, Details}; - enospc -> {Reason, Details}; - _ -> {undef, Details ++ " (" ++ atom_to_list(Reason) ++ ")"} - end. - -%%------------------------------------------------------------------- -%% read(State) -> -%% {more, Bin, NewState} | {last, Bin, FileSize} | {error, {Code, Text}} -%% -%% State = term() -%% NewState = term() -%% Bin = binary() -%% FileSize = integer() -%% Code = undef | enoent | eacces | enospc | -%% badop | eexist | baduser | badopt | -%% integer() -%% Text = string() -%% -%% Reads a chunk from the file -%% -%% The file is automatically closed when the last chunk is read. -%%------------------------------------------------------------------- - -read(#state{access = read} = State) -> - BlkSize = State#state.blksize, - case file:read(State#state.fd, BlkSize) of - {ok, Bin} when is_binary(Bin), size(Bin) =:= BlkSize -> - Count = State#state.count + size(Bin), - {more, Bin, State#state{count = Count}}; - {ok, Bin} when is_binary(Bin), size(Bin) < BlkSize -> - file:close(State#state.fd), - Count = State#state.count + size(Bin), - {last, Bin, Count}; - eof -> - {last, <<>>, State#state.count}; - {error, Reason} -> - file:close(State#state.fd), - {error, file_error(Reason)} - end. - -%%------------------------------------------------------------------- -%% write(Bin, State) -> -%% {more, NewState} | {last, FileSize} | {error, {Code, Text}} -%% -%% State = term() -%% NewState = term() -%% Bin = binary() -%% FileSize = integer() -%% Code = undef | enoent | eacces | enospc | -%% badop | eexist | baduser | badopt | -%% integer() -%% Text = string() -%% -%% Writes a chunk to the file -%% -%% The file is automatically closed when the last chunk is written -%%------------------------------------------------------------------- - -write(Bin, #state{access = write} = State) when is_binary(Bin) -> - Size = size(Bin), - BlkSize = State#state.blksize, - case file:write(State#state.fd, Bin) of - ok when Size =:= BlkSize-> - Count = State#state.count + Size, - {more, State#state{count = Count}}; - ok when Size < BlkSize-> - file:close(State#state.fd), - Count = State#state.count + Size, - {last, Count}; - {error, Reason} -> - file:close(State#state.fd), - file:delete(State#state.filename), - {error, file_error(Reason)} - end. - -%%------------------------------------------------------------------- -%% abort(Code, Text, State) -> ok -%% -%% State = term() -%% Code = undef | enoent | eacces | enospc | -%% badop | eexist | baduser | badopt | -%% badblk | integer() -%% Text = string() -%% -%% Aborts the file transfer -%%------------------------------------------------------------------- - -abort(_Code, _Text, #state{fd = Fd, access = Access} = State) -> - file:close(Fd), - case Access of - write -> - ok = file:delete(State#state.filename); - read -> - ok - end. - -%%------------------------------------------------------------------- -%% Process options -%%------------------------------------------------------------------- - -handle_options(Access, Filename, Mode, Options, InitialState) when Mode =:= "octet" -> - Filename2 = handle_filename(Filename, InitialState), - Options2 = do_handle_options(Access, Filename2, Options), - {ok, Filename2, Options2}; -handle_options(_Access, _Filename, Mode, _Options, _InitialState) -> - {error, {badop, "Illegal mode " ++ Mode}}. - -handle_filename(Filename, InitialState) when is_list(InitialState) -> - case lists:keysearch(root_dir, 1, InitialState) of - {value, {_, Dir}} -> - case catch filename_join(Dir, Filename) of - {'EXIT', _} -> - throw({error, {badop, "Internal error. root_dir is not a string"}}); - Filename2 -> - Filename2 - end; - false -> - Filename - end; -handle_filename(_Filename, State) when is_record(State, state) -> - State#state.filename. - -filename_join(Dir, Filename) -> - case filename:pathtype(Filename) of - absolute -> - [_ | RelFilename] = filename:split(Filename), - filename:join([Dir, RelFilename]); - _ -> - filename:join([Dir, Filename]) - end. - -do_handle_options(Access, Filename, [{Key, Val} | T]) -> - case Key of - "tsize" -> - case Access of - read when Val =:= "0" -> - case file:read_file_info(Filename) of - {ok, FI} -> - Tsize = integer_to_list(FI#file_info.size), - [{Key, Tsize} | do_handle_options(Access, Filename, T)]; - {error, _} -> - do_handle_options(Access, Filename, T) - end; - _ -> - handle_integer(Access, Filename, Key, Val, T, 0, infinity) - end; - "blksize" -> - handle_integer(Access, Filename, Key, Val, T, 8, 65464); - "timeout" -> - handle_integer(Access, Filename, Key, Val, T, 1, 255); - _ -> - do_handle_options(Access, Filename, T) - end; -do_handle_options(_Access, _Filename, []) -> - []. - - -handle_integer(Access, Filename, Key, Val, Options, Min, Max) -> - case catch list_to_integer(Val) of - {'EXIT', _} -> - do_handle_options(Access, Filename, Options); - Int when Int >= Min, Int =< Max -> - [{Key, Val} | do_handle_options(Access, Filename, Options)]; - Int when Int >= Min, Max =:= infinity -> - [{Key, Val} | do_handle_options(Access, Filename, Options)]; - _Int -> - throw({error, {badopt, "Illegal " ++ Key ++ " value " ++ Val}}) - end. - -lookup_blksize(Options) -> - case lists:keysearch("blksize", 1, Options) of - {value, {_, Val}} -> - list_to_integer(Val); - false -> - 512 - end. diff --git a/src/couch_inets/tftp_lib.erl b/src/couch_inets/tftp_lib.erl deleted file mode 100644 index f73b7a68..00000000 --- a/src/couch_inets/tftp_lib.erl +++ /dev/null @@ -1,418 +0,0 @@ -%%%------------------------------------------------------------------- -%%% File : tftp_lib.erl -%%% Author : Hakan Mattsson <hakan@erix.ericsson.se> -%%% Description : Option parsing, decode, encode etc. -%%% -%%% Created : 18 May 2004 by Hakan Mattsson <hakan@erix.ericsson.se> -%%%------------------------------------------------------------------- - --module(tftp_lib). - -%%------------------------------------------------------------------- -%% Interface -%%------------------------------------------------------------------- - -%% application internal functions --export([ - parse_config/1, - parse_config/2, - decode_msg/1, - encode_msg/1, - replace_val/3, - to_lower/1, - host_to_string/1 - ]). - -%%------------------------------------------------------------------- -%% Defines -%%------------------------------------------------------------------- - --include("tftp.hrl"). - --define(LOWER(Char), - if - Char >= $A, Char =< $Z -> - Char - ($A - $a); - true -> - Char - end). - -%%------------------------------------------------------------------- -%% Config -%%------------------------------------------------------------------- - -parse_config(Options) -> - parse_config(Options, #config{}). - -parse_config(Options, Config) -> - do_parse_config(Options, Config). - -do_parse_config([{Key, Val} | Tail], Config) when is_record(Config, config) -> - case Key of - debug -> - case Val of - none -> - do_parse_config(Tail, Config#config{debug_level = Val}); - error -> - do_parse_config(Tail, Config#config{debug_level = Val}); - brief -> - do_parse_config(Tail, Config#config{debug_level = Val}); - normal -> - do_parse_config(Tail, Config#config{debug_level = Val}); - verbose -> - do_parse_config(Tail, Config#config{debug_level = Val}); - all -> - do_parse_config(Tail, Config#config{debug_level = Val}); - _ -> - exit({badarg, {Key, Val}}) - end; - host -> - if - is_list(Val) -> - do_parse_config(Tail, Config#config{udp_host = Val}); - is_tuple(Val), size(Val) =:= 4 -> - do_parse_config(Tail, Config#config{udp_host = Val}); - is_tuple(Val), size(Val) =:= 8 -> - do_parse_config(Tail, Config#config{udp_host = Val}); - true -> - exit({badarg, {Key, Val}}) - end; - port -> - if - is_integer(Val), Val >= 0 -> - Config2 = Config#config{udp_port = Val, udp_options = Config#config.udp_options}, - do_parse_config(Tail, Config2); - true -> - exit({badarg, {Key, Val}}) - end; - port_policy -> - case Val of - random -> - do_parse_config(Tail, Config#config{port_policy = Val}); - 0 -> - do_parse_config(Tail, Config#config{port_policy = random}); - MinMax when is_integer(MinMax), MinMax > 0 -> - do_parse_config(Tail, Config#config{port_policy = {range, MinMax, MinMax}}); - {range, Min, Max} when Max >= Min, - integer(Min), Min > 0, - integer(Max), Max > 0 -> - do_parse_config(Tail, Config#config{port_policy = Val}); - true -> - exit({badarg, {Key, Val}}) - end; - udp when is_list(Val) -> - Fun = - fun({K, V}, List) when K /= active -> - replace_val(K, V, List); - (V, List) when V /= list, V /= binary -> - List ++ [V]; - (V, _List) -> - exit({badarg, {udp, [V]}}) - end, - UdpOptions = lists:foldl(Fun, Config#config.udp_options, Val), - do_parse_config(Tail, Config#config{udp_options = UdpOptions}); - use_tsize -> - case Val of - true -> - do_parse_config(Tail, Config#config{use_tsize = Val}); - false -> - do_parse_config(Tail, Config#config{use_tsize = Val}); - _ -> - exit({badarg, {Key, Val}}) - end; - max_tsize -> - if - Val =:= infinity -> - do_parse_config(Tail, Config#config{max_tsize = Val}); - integer(Val), Val >= 0 -> - do_parse_config(Tail, Config#config{max_tsize = Val}); - true -> - exit({badarg, {Key, Val}}) - end; - max_conn -> - if - Val =:= infinity -> - do_parse_config(Tail, Config#config{max_conn = Val}); - integer(Val), Val > 0 -> - do_parse_config(Tail, Config#config{max_conn = Val}); - true -> - exit({badarg, {Key, Val}}) - end; - _ when is_list(Key), is_list(Val) -> - Key2 = to_lower(Key), - Val2 = to_lower(Val), - TftpOptions = replace_val(Key2, Val2, Config#config.user_options), - do_parse_config(Tail, Config#config{user_options = TftpOptions}); - reject -> - case Val of - read -> - Rejected = [Val | Config#config.rejected], - do_parse_config(Tail, Config#config{rejected = Rejected}); - write -> - Rejected = [Val | Config#config.rejected], - do_parse_config(Tail, Config#config{rejected = Rejected}); - _ when is_list(Val) -> - Rejected = [Val | Config#config.rejected], - do_parse_config(Tail, Config#config{rejected = Rejected}); - _ -> - exit({badarg, {Key, Val}}) - end; - callback -> - case Val of - {RegExp, Mod, State} when is_list(RegExp), atom(Mod) -> - case regexp:parse(RegExp) of - {ok, Internal} -> - Callback = #callback{regexp = RegExp, - internal = Internal, - module = Mod, - state = State}, - Callbacks = Config#config.callbacks ++ [Callback], - do_parse_config(Tail, Config#config{callbacks = Callbacks}); - {error, Reason} -> - exit({badarg, {Key, Val}, Reason}) - end; - _ -> - exit({badarg, {Key, Val}}) - end; - _ -> - exit({badarg, {Key, Val}}) - end; -do_parse_config([], Config) when is_record(Config, config) -> - UdpOptions = Config#config.udp_options, - IsInet6 = lists:member(inet6, UdpOptions), - IsInet = lists:member(inet, UdpOptions), - Host = Config#config.udp_host, - Host2 = - if - (IsInet and not IsInet6); (not IsInet and not IsInet6) -> - case inet:getaddr(Host, inet) of - {ok, Addr} -> - Addr; - {error, Reason} -> - exit({badarg, {host, Reason}}) - end; - (IsInet6 and not IsInet) -> - case inet:getaddr(Host, inet6) of - {ok, Addr} -> - Addr; - {error, Reason} -> - exit({badarg, {host, Reason}}) - end; - true -> - %% Conflicting options - exit({badarg, {udp, [inet]}}) - end, - UdpOptions2 = lists:reverse(UdpOptions), - TftpOptions = lists:reverse(Config#config.user_options), - Config#config{udp_host = Host2, udp_options = UdpOptions2, user_options = TftpOptions}; -do_parse_config(Options, Config) when is_record(Config, config) -> - exit({badarg, Options}). - -host_to_string(Host) -> - case Host of - String when is_list(String) -> - String; - {A1, A2, A3, A4} -> % inet - lists:concat([A1, ".", A2, ".", A3, ".",A4]); - {A1, A2, A3, A4, A5, A6, A7, A8} -> % inet6 - lists:concat([ - int16_to_hex(A1), "::", - int16_to_hex(A2), "::", - int16_to_hex(A3), "::", - int16_to_hex(A4), "::", - int16_to_hex(A5), "::", - int16_to_hex(A6), "::", - int16_to_hex(A7), "::", - int16_to_hex(A8) - ]) - end. - -int16_to_hex(0) -> - [$0]; -int16_to_hex(I) -> - N1 = ((I bsr 8) band 16#ff), - N2 = (I band 16#ff), - [code_character(N1 div 16), code_character(N1 rem 16), - code_character(N2 div 16), code_character(N2 rem 16)]. - -code_character(N) when N < 10 -> - $0 + N; -code_character(N) -> - $A + (N - 10). - -%%------------------------------------------------------------------- -%% Decode -%%------------------------------------------------------------------- - -decode_msg(Bin) when is_binary(Bin) -> - case Bin of - <<?TFTP_OPCODE_RRQ:16/integer, Tail/binary>> -> - case decode_strings(Tail, [keep_case, lower_case]) of - [Filename, Mode | Strings] -> - Options = decode_options(Strings), - #tftp_msg_req{access = read, - filename = Filename, - mode = to_lower(Mode), - options = Options}; - [_Filename | _Strings] -> - exit(#tftp_msg_error{code = undef, - text = "Missing mode"}); - _ -> - exit(#tftp_msg_error{code = undef, - text = "Missing filename"}) - end; - <<?TFTP_OPCODE_WRQ:16/integer, Tail/binary>> -> - case decode_strings(Tail, [keep_case, lower_case]) of - [Filename, Mode | Strings] -> - Options = decode_options(Strings), - #tftp_msg_req{access = write, - filename = Filename, - mode = to_lower(Mode), - options = Options}; - [_Filename | _Strings] -> - exit(#tftp_msg_error{code = undef, - text = "Missing mode"}); - _ -> - exit(#tftp_msg_error{code = undef, - text = "Missing filename"}) - end; - <<?TFTP_OPCODE_DATA:16/integer, SeqNo:16/integer, Data/binary>> -> - #tftp_msg_data{block_no = SeqNo, data = Data}; - <<?TFTP_OPCODE_ACK:16/integer, SeqNo:16/integer>> -> - #tftp_msg_ack{block_no = SeqNo}; - <<?TFTP_OPCODE_ERROR:16/integer, ErrorCode:16/integer, Tail/binary>> -> - case decode_strings(Tail, [keep_case]) of - [ErrorText] -> - ErrorCode2 = decode_error_code(ErrorCode), - #tftp_msg_error{code = ErrorCode2, - text = ErrorText}; - _ -> - exit(#tftp_msg_error{code = undef, - text = "Trailing garbage"}) - end; - <<?TFTP_OPCODE_OACK:16/integer, Tail/binary>> -> - Strings = decode_strings(Tail, [lower_case]), - Options = decode_options(Strings), - #tftp_msg_oack{options = Options}; - _ -> - exit(#tftp_msg_error{code = undef, - text = "Invalid syntax"}) - end. - -decode_strings(Bin, Cases) when is_binary(Bin), is_list(Cases) -> - do_decode_strings(Bin, Cases, []). - -do_decode_strings(<<>>, _Cases, Strings) -> - lists:reverse(Strings); -do_decode_strings(Bin, [Case | Cases], Strings) -> - {String, Tail} = decode_string(Bin, Case, []), - if - Cases =:= [] -> - do_decode_strings(Tail, [Case], [String | Strings]); - true -> - do_decode_strings(Tail, Cases, [String | Strings]) - end. - -decode_string(<<Char:8/integer, Tail/binary>>, Case, String) -> - if - Char =:= 0 -> - {lists:reverse(String), Tail}; - Case =:= keep_case -> - decode_string(Tail, Case, [Char | String]); - Case =:= lower_case -> - Char2 = ?LOWER(Char), - decode_string(Tail, Case, [Char2 | String]) - end; -decode_string(<<>>, _Case, _String) -> - exit(#tftp_msg_error{code = undef, text = "Trailing null missing"}). - -decode_options([Key, Value | Strings]) -> - [{to_lower(Key), Value} | decode_options(Strings)]; -decode_options([]) -> - []. - -decode_error_code(Int) -> - case Int of - ?TFTP_ERROR_UNDEF -> undef; - ?TFTP_ERROR_ENOENT -> enoent; - ?TFTP_ERROR_EACCES -> eacces; - ?TFTP_ERROR_ENOSPC -> enospc; - ?TFTP_ERROR_BADOP -> badop; - ?TFTP_ERROR_BADBLK -> badblk; - ?TFTP_ERROR_EEXIST -> eexist; - ?TFTP_ERROR_BADUSER -> baduser; - ?TFTP_ERROR_BADOPT -> badopt; - Int when is_integer(Int), Int >= 0, Int =< 65535 -> Int; - _ -> exit(#tftp_msg_error{code = undef, text = "Error code outside range."}) - end. - -%%------------------------------------------------------------------- -%% Encode -%%------------------------------------------------------------------- - -encode_msg(#tftp_msg_req{access = Access, - filename = Filename, - mode = Mode, - options = Options}) -> - OpCode = case Access of - read -> ?TFTP_OPCODE_RRQ; - write -> ?TFTP_OPCODE_WRQ - end, - [ - <<OpCode:16/integer>>, - Filename, - 0, - Mode, - 0, - [[Key, 0, Val, 0] || {Key, Val} <- Options] - ]; -encode_msg(#tftp_msg_data{block_no = BlockNo, data = Data}) when BlockNo =< 65535 -> - [ - <<?TFTP_OPCODE_DATA:16/integer, BlockNo:16/integer>>, - Data - ]; -encode_msg(#tftp_msg_ack{block_no = BlockNo}) when BlockNo =< 65535 -> - <<?TFTP_OPCODE_ACK:16/integer, BlockNo:16/integer>>; -encode_msg(#tftp_msg_error{code = Code, text = Text}) -> - IntCode = encode_error_code(Code), - [ - <<?TFTP_OPCODE_ERROR:16/integer, IntCode:16/integer>>, - Text, - 0 - ]; -encode_msg(#tftp_msg_oack{options = Options}) -> - [ - <<?TFTP_OPCODE_OACK:16/integer>>, - [[Key, 0, Val, 0] || {Key, Val} <- Options] - ]. - -encode_error_code(Code) -> - case Code of - undef -> ?TFTP_ERROR_UNDEF; - enoent -> ?TFTP_ERROR_ENOENT; - eacces -> ?TFTP_ERROR_EACCES; - enospc -> ?TFTP_ERROR_ENOSPC; - badop -> ?TFTP_ERROR_BADOP; - badblk -> ?TFTP_ERROR_BADBLK; - eexist -> ?TFTP_ERROR_EEXIST; - baduser -> ?TFTP_ERROR_BADUSER; - badopt -> ?TFTP_ERROR_BADOPT; - Int when is_integer(Int), Int >= 0, Int =< 65535 -> Int - end. - -%%------------------------------------------------------------------- -%% Miscellaneous -%%------------------------------------------------------------------- - -replace_val(Key, Val, List) -> - case lists:keysearch(Key, 1, List) of - false -> - List ++ [{Key, Val}]; - {value, {_, OldVal}} when OldVal =:= Val -> - List; - {value, {_, _}} -> - lists:keyreplace(Key, 1, List, {Key, Val}) - end. - -to_lower(Chars) -> - [?LOWER(Char) || Char <- Chars]. diff --git a/src/couch_inets/tftp_sup.erl b/src/couch_inets/tftp_sup.erl deleted file mode 100644 index 5a176311..00000000 --- a/src/couch_inets/tftp_sup.erl +++ /dev/null @@ -1,81 +0,0 @@ -%% ``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$ -%% -%%---------------------------------------------------------------------- -%% Purpose: The top supervisor for tftp hangs under inets_sup. -%%---------------------------------------------------------------------- - --module(tftp_sup). - --behaviour(supervisor). - -%% API --export([start_link/1]). --export([start_child/1]). - -%% Supervisor callback --export([init/1]). - -%%%========================================================================= -%%% API -%%%========================================================================= - -start_link(TftpServices) -> - supervisor:start_link({local, ?MODULE}, ?MODULE, [TftpServices]). - -start_child(Args) -> - supervisor:start_child(?MODULE, Args). - -%%%========================================================================= -%%% Supervisor callback -%%%========================================================================= - -init([Services]) when is_list(Services) -> - RestartStrategy = one_for_one, - MaxR = 10, - MaxT = 3600, - KillAfter = timer:seconds(3), - Children = [worker_spec(KillAfter, Options) || {tftpd, Options} <- Services], - {ok, {{RestartStrategy, MaxR, MaxT}, Children}}. - -%%%========================================================================= -%%% Internal functions -%%%========================================================================= - -worker_spec(KillAfter, Options) -> - Modules = [proc_lib, tftp, tftp_engine], - KA = supervisor_timeout(KillAfter), - Name = unique_name(Options), - {Name, {tftp, start, [Options]}, permanent, KA, worker, Modules}. - -unique_name(Options) -> - case lists:keysearch(port, 1, Options) of - {value, {_, Port}} when is_integer(Port), Port > 0 -> - {tftpd, Port}; - _ -> - {tftpd, erlang:now()} - end. - -%% supervisor_spec(Name) -> -%% {Name, {Name, start, []}, permanent, infinity, supervisor, -%% [Name, supervisor]}. - --ifdef(debug_shutdown). -supervisor_timeout(_KillAfter) -> timer:hours(24). --else. -supervisor_timeout(KillAfter) -> KillAfter. --endif. diff --git a/src/couchdb/Makefile.am b/src/couchdb/Makefile.am index 4b0d553a..c7a30cac 100644 --- a/src/couchdb/Makefile.am +++ b/src/couchdb/Makefile.am @@ -36,6 +36,7 @@ couch_file_collection = \ couch_doc.erl \ couch_event_sup.erl \ couch_file.erl \ + couch_httpd.erl \ couch_ft_query.erl \ couch_key_tree.erl \ couch_log.erl \ @@ -45,8 +46,7 @@ couch_file_collection = \ couch_server_sup.erl \ couch_stream.erl \ couch_util.erl \ - couch_view.erl \ - mod_couch.erl + couch_view.erl couchebin_DATA = \ cjson.beam \ @@ -58,6 +58,7 @@ couchebin_DATA = \ couch_event_sup.beam \ couch_file.beam \ couch_ft_query.beam \ + couch_httpd.beam \ couch_key_tree.beam \ couch_log.beam \ couch_query_servers.beam \ @@ -66,8 +67,7 @@ couchebin_DATA = \ couch_server_sup.beam \ couch_stream.beam \ couch_util.beam \ - couch_view.beam \ - mod_couch.beam + couch_view.beam couchinclude_DATA = couch_db.hrl diff --git a/src/couchdb/cjson.erl b/src/couchdb/cjson.erl index 042d5c41..6e144c9e 100644 --- a/src/couchdb/cjson.erl +++ b/src/couchdb/cjson.erl @@ -410,7 +410,7 @@ tokenize([], S=#decoder{state=trim}) -> tokenize([L | Rest], S) when is_list(L) -> tokenize(L ++ Rest, S); tokenize([B | Rest], S) when is_binary(B) -> - tokenize(xmerl_ucs:from_utf8(B) ++ Rest, S); + tokenize(xmerl_ucs:from_utf8(B) ++ Rest, S#decoder{input_encoding=unicode}); tokenize("\r\n" ++ Rest, S) -> tokenize(Rest, ?INC_LINE(S)); tokenize("\n" ++ Rest, S) -> diff --git a/src/couchdb/couch.app.tpl.in b/src/couchdb/couch.app.tpl.in index 5ddf0989..95bc6708 100644 --- a/src/couchdb/couch.app.tpl.in +++ b/src/couchdb/couch.app.tpl.in @@ -13,7 +13,7 @@ couch_key_tree, couch_view, couch_util, - mod_couch, + couch_httpd, couch_event_sup, couch_db_update_notifier, couch_ft_query, @@ -25,5 +25,4 @@ couch_view, couch_query_servers, couch_ft_query]}, - {applications,[kernel,stdlib,xmerl,couch_inets]}, - {mod,{couch_server,[]}}]}. + {applications,[kernel,stdlib,xmerl,inets,mochiweb]}]}. diff --git a/src/couchdb/couch_db.erl b/src/couchdb/couch_db.erl index cdb0598e..60d951c9 100644 --- a/src/couchdb/couch_db.erl +++ b/src/couchdb/couch_db.erl @@ -246,6 +246,7 @@ prepare_doc_for_new_edit(Db, #doc{id=Id,revs=[NewRev|PrevRevs]}=Doc, OldFullDocI end. update_docs(MainPid, Docs, Options) -> + % go ahead and generate the new revision ids for the documents. Docs2 = lists:map( fun(#doc{id=Id,revs=Revs}=Doc) -> case Id of @@ -261,7 +262,7 @@ update_docs(MainPid, Docs, Options) -> Ids = [Id || [#doc{id=Id}|_] <- DocBuckets], Db = get_db(MainPid), - % first things first, lookup the doc by id and get the most recent + % lookup the doc by id and get the most recent ExistingDocs = get_full_doc_infos(Db, Ids), @@ -276,7 +277,6 @@ update_docs(MainPid, Docs, Options) -> [prepare_doc_for_new_edit(Db, Doc, OldFullDocInfo, LeafRevsDict) || Doc <- Bucket] end, DocBuckets, ExistingDocs), - % flush unwritten binaries to disk. DocBuckets3 = [[doc_flush_binaries(Doc, Db#db.fd) || Doc <- Bucket] || Bucket <- DocBuckets2], @@ -607,7 +607,7 @@ open_doc_int(Db, #doc_info{id=Id,rev=Rev,deleted=IsDeleted,summary_pointer=Sp}=D Doc = make_doc(Db, Id, IsDeleted, Sp, [Rev]), {ok, Doc#doc{meta=doc_meta_info(DocInfo, [], Options)}}; open_doc_int(Db, #full_doc_info{id=Id,rev_tree=RevTree}=FullDocInfo, Options) -> - #doc_info{deleted=IsDeleted,rev=Rev, summary_pointer=Sp} = DocInfo = + #doc_info{deleted=IsDeleted,rev=Rev,summary_pointer=Sp} = DocInfo = couch_doc:to_doc_info(FullDocInfo), {[{_Rev,_Value, Revs}], []} = couch_key_tree:get(RevTree, [Rev]), Doc = make_doc(Db, Id, IsDeleted, Sp, Revs), @@ -626,7 +626,14 @@ doc_meta_info(DocInfo, RevTree, Options) -> true -> {[RevPath],[]} = couch_key_tree:get_full_key_paths(RevTree, [DocInfo#doc_info.rev]), - [{revs_info, [{Rev, Deleted} || {Rev, {Deleted, _Sp0}} <- RevPath]}] + [{revs_info, lists:map( + fun({Rev, {true, _Sp}}) -> + {Rev, deleted}; + ({Rev, {false, _Sp}}) -> + {Rev, available}; + ({Rev, ?REV_MISSING}) -> + {Rev, missing} + end, RevPath)}] end ++ case lists:member(conflicts, Options) of false -> []; diff --git a/src/couchdb/couch_doc.erl b/src/couchdb/couch_doc.erl index a9ef55f7..1ced93b3 100644 --- a/src/couchdb/couch_doc.erl +++ b/src/couchdb/couch_doc.erl @@ -128,13 +128,12 @@ to_doc_info(#full_doc_info{id=Id,update_seq=Seq,rev_tree=Tree}) -> [{RevId, {IsDeleted, SummaryPointer}, _Path} | Rest] = SortedLeafRevs, {ConflictRevTuples, DeletedConflictRevTuples} = - lists:splitwith(fun({_ConflictRevId, {IsDeleted1, _SummaryPointer}, _}) -> + lists:splitwith(fun({_ConflictRevId, {IsDeleted1, _Sp}, _}) -> not IsDeleted1 end, Rest), ConflictRevs = [RevId1 || {RevId1, _, _} <- ConflictRevTuples], DeletedConflictRevs = [RevId2 || {RevId2, _, _} <- DeletedConflictRevTuples], - #doc_info{ id=Id, update_seq=Seq, diff --git a/src/couchdb/couch_httpd.erl b/src/couchdb/couch_httpd.erl new file mode 100644 index 00000000..0f2b89a5 --- /dev/null +++ b/src/couchdb/couch_httpd.erl @@ -0,0 +1,832 @@ +% Licensed under the Apache License, Version 2.0 (the "License"); you may not +% use this file except in compliance with the License. You may obtain a copy of +% the License at +% +% http://www.apache.org/licenses/LICENSE-2.0 +% +% Unless required by applicable law or agreed to in writing, software +% distributed under the License is distributed on an "AS IS" BASIS, WITHOUT +% WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the +% License for the specific language governing permissions and limitations under +% the License. + +-module(couch_httpd). +-include("couch_db.hrl"). + +-export([start_link/3, stop/0]). + +-record(doc_query_args, { + options = [], + rev = "", + open_revs = "" +}). + +-record(view_query_args, { + start_key = nil, + end_key = <<>>, + count = 10000000000, % a huge huge default number. Picked so we don't have + % to do different logic for when there is no count + % limit + update = true, + direction = fwd, + start_docid = nil, + end_docid = <<>>, + skip = 0 +}). + +start_link(BindAddress, Port, DocumentRoot) -> + Loop = fun (Req) -> handle_request(Req, DocumentRoot) end, + mochiweb_http:start([ + {loop, Loop}, + {name, ?MODULE}, + {ip, BindAddress}, + {port, Port} + ]). + +stop() -> + mochiweb_http:stop(?MODULE). + +handle_request(Req, DocumentRoot) -> + % alias HEAD to GET as mochiweb takes care of stripping the body + Method = case Req:get(method) of + 'HEAD' -> 'GET'; + Other -> Other + end, + + % for the path, use the raw path with the query string and fragment + % removed, but URL quoting left intact + {Path, _, _} = mochiweb_util:urlsplit_path(Req:get(raw_path)), + + couch_log:debug("Method: ~p", [Method]), + couch_log:debug("Request URI: ~p", [Path]), + couch_log:debug("Headers: ~p", [mochiweb_headers:to_list(Req:get(headers))]), + + {ok, Resp} = case catch(handle_request(Req, DocumentRoot, Method, Path)) of + {ok, Resp0} -> + {ok, Resp0}; + Error -> + send_error(Req, Error) + end, + + couch_log:info("~s - - ~p ~B", [ + Req:get(peer), + atom_to_list(Req:get(method)) ++ " " ++ Path, + Resp:get(code) + ]). + +handle_request(Req, DocumentRoot, Method, Path) -> + case Path of + "/" -> + handle_welcome_request(Req, Method); + "/_all_dbs" -> + handle_all_dbs_request(Req, Method); + "/favicon.ico" -> + {ok, Req:serve_file("favicon.ico", DocumentRoot)}; + "/_replicate" -> + handle_replicate_request(Req, Method); + "/_utils" -> + {ok, Req:respond({301, [{"Location", "/_utils/"}], <<>>})}; + "/_utils/" ++ PathInfo -> + {ok, Req:serve_file(PathInfo, DocumentRoot)}; + _Else -> + handle_db_request(Req, Method, {Path}) + end. + +% Global request handlers + +handle_welcome_request(Req, 'GET') -> + send_json(Req, {obj, [ + {"couchdb", "Welcome"}, + {"version", couch_server:get_version()} + ]}); + +handle_welcome_request(_Req, _Method) -> + throw({method_not_allowed, "GET,HEAD"}). + +handle_all_dbs_request(Req, 'GET') -> + {ok, DbNames} = couch_server:all_databases(), + send_json(Req, list_to_tuple(DbNames)); + +handle_all_dbs_request(_Req, _Method) -> + throw({method_not_allowed, "GET,HEAD"}). + +handle_replicate_request(Req, 'POST') -> + {obj, Props} = cjson:decode(Req:recv_body()), + Source = proplists:get_value("source", Props), + Target = proplists:get_value("target", Props), + {obj, Options} = proplists:get_value("options", Props, {obj, []}), + {ok, {obj, JsonResults}} = couch_rep:replicate(Source, Target, Options), + send_json(Req, {obj, [{ok, true} | JsonResults]}); + +handle_replicate_request(_Req, _Method) -> + throw({method_not_allowed, "POST"}). + +% Database request handlers + +handle_db_request(Req, Method, {Path}) -> + UriParts = string:tokens(Path, "/"), + [DbName|Rest] = UriParts, + handle_db_request(Req, Method, {mochiweb_util:unquote(DbName), Rest}); + +handle_db_request(Req, 'PUT', {DbName, []}) -> + case couch_server:create(DbName, []) of + {ok, _Db} -> + send_json(Req, 201, {obj, [{ok, true}]}); + {error, database_already_exists} -> + Msg = io_lib:format("Database ~p already exists.", [DbName]), + throw({database_already_exists, Msg}); + Error -> + Msg = io_lib:format("Error creating database ~p: ~p", [DbName, Error]), + throw({unknown_error, Msg}) + end; + +handle_db_request(Req, Method, {DbName, Rest}) -> + case couch_server:open(DbName) of + {ok, Db} -> + handle_db_request(Req, Method, {DbName, Db, Rest}); + Error -> + throw(Error) + end; + +handle_db_request(Req, 'DELETE', {DbName, _Db, []}) -> + ok = couch_server:delete(DbName), + send_json(Req, 202, {obj, [ + {ok, true} + ]}); + +handle_db_request(Req, 'GET', {DbName, Db, []}) -> + {ok, DbInfo} = couch_db:get_db_info(Db), + send_json(Req, {obj, [{db_name, DbName} | DbInfo]}); + +handle_db_request(Req, 'POST', {_DbName, Db, []}) -> + % TODO: Etag handling + Json = cjson:decode(Req:recv_body()), + Doc = couch_doc:from_json_obj(Json), + DocId = couch_util:new_uuid(), + {ok, NewRev} = couch_db:update_doc(Db, Doc#doc{id=DocId, revs=[]}, []), + send_json(Req, 201, {obj, [ + {ok, true}, + {id, DocId}, + {rev, NewRev} + ]}); + +handle_db_request(_Req, _Method, {_DbName, _Db, []}) -> + throw({method_not_allowed, "DELETE,GET,HEAD,POST"}); + +handle_db_request(Req, 'POST', {_DbName, Db, ["_bulk_docs"]}) -> + Options = [], % put options here. + {obj, JsonProps} = cjson:decode(Req:recv_body()), + DocsArray = proplists:get_value("docs", JsonProps), + % convert all the doc elements to native docs + case proplists:get_value("new_edits", JsonProps, true) of + true -> + Docs = lists:map( + fun({obj, ObjProps} = JsonObj) -> + Doc = couch_doc:from_json_obj(JsonObj), + Id = case Doc#doc.id of + "" -> couch_util:new_uuid(); + Id0 -> Id0 + end, + Revs = case proplists:get_value("_rev", ObjProps) of + undefined -> []; + Rev -> [Rev] + end, + Doc#doc{id=Id,revs=Revs} + end, + tuple_to_list(DocsArray)), + {ok, ResultRevs} = couch_db:update_docs(Db, Docs, Options), + + % output the results + DocResults = lists:zipwith( + fun(Doc, NewRev) -> + {obj, [{"id", Doc#doc.id}, {"rev", NewRev}]} + end, + Docs, ResultRevs), + send_json(Req, 201, {obj, [ + {ok, true}, + {new_revs, list_to_tuple(DocResults)} + ]}); + + false -> + Docs = [couch_doc:from_json_obj(JsonObj) || JsonObj <- tuple_to_list(DocsArray)], + ok = couch_db:save_docs(Db, Docs, Options), + send_json(Req, 201, {obj, [ + {ok, true} + ]}) + end; + +handle_db_request(_Req, _Method, {_DbName, _Db, ["_bulk_docs"]}) -> + throw({method_not_allowed, "POST"}); + +handle_db_request(Req, 'POST', {_DbName, Db, ["_compact"]}) -> + ok = couch_db:start_compact(Db), + send_json(Req, 202, {obj, [ + {ok, true} + ]}); + +handle_db_request(_Req, _Method, {_DbName, _Db, ["_compact"]}) -> + throw({method_not_allowed, "POST"}); + +handle_db_request(Req, 'GET', {DbName, _Db, ["_search"]}) -> + case Req:parse_qs() of + [{"q", Query}] when (length(Query) > 0) -> + {ok, Response} = couch_ft_query:execute(DbName, Query), + send_json(Req, {obj, [{ok, true} | Response]}); + _Error -> + throw({no_fulltext_query, "Empty Query String"}) + end; + +handle_db_request(_Req, _Method, {_DbName, _Db, ["_search"]}) -> + throw({method_not_allowed, "GET,HEAD"}); + +% View request handlers + +handle_db_request(Req, 'GET', {_DbName, Db, ["_all_docs"]}) -> + #view_query_args{ + start_key = StartKey, + start_docid = StartDocId, + count = Count, + skip = SkipCount, + direction = Dir + } = QueryArgs = parse_view_query(Req), + {ok, Info} = couch_db:get_db_info(Db), + TotalRowCount = proplists:get_value(doc_count, Info), + + StartId = if is_list(StartKey) -> StartKey; + true -> StartDocId + end, + + FoldlFun = make_view_fold_fun(Req, QueryArgs), + AdapterFun = fun(#full_doc_info{id=Id}=FullDocInfo, Offset, Acc) -> + case couch_doc:to_doc_info(FullDocInfo) of + #doc_info{deleted=false, rev=Rev} -> + FoldlFun(Id, Id, {obj, [{rev, Rev}]}, Offset, TotalRowCount, Acc); + #doc_info{deleted=true} -> + {ok, Acc} + end + end, + {ok, FoldResult} = couch_db:enum_docs(Db, StartId, Dir, AdapterFun, + {Count, SkipCount, undefined, []}), + finish_view_fold(Req, {ok, TotalRowCount, FoldResult}); + +handle_db_request(_Req, _Method, {_DbName, _Db, ["_all_docs"]}) -> + throw({method_not_allowed, "GET,HEAD"}); + +handle_db_request(Req, 'GET', {_DbName, Db, ["_all_docs_by_seq"]}) -> + #view_query_args{ + start_key = StartKey, + count = Count, + skip = SkipCount, + direction = Dir + } = QueryArgs = parse_view_query(Req), + + {ok, Info} = couch_db:get_db_info(Db), + TotalRowCount = proplists:get_value(doc_count, Info), + + FoldlFun = make_view_fold_fun(Req, QueryArgs), + StartKey2 = case StartKey of + nil -> 0; + <<>> -> 100000000000; + StartKey when is_integer(StartKey) -> StartKey + end, + {ok, FoldResult} = couch_db:enum_docs_since(Db, StartKey2, Dir, + fun(DocInfo, Offset, Acc) -> + #doc_info{ + id=Id, + rev=Rev, + update_seq=UpdateSeq, + deleted=Deleted, + conflict_revs=ConflictRevs, + deleted_conflict_revs=DelConflictRevs + } = DocInfo, + Json = {obj, + [{"rev", Rev}] ++ + case ConflictRevs of + [] -> []; + _ -> [{"conflicts", list_to_tuple(ConflictRevs)}] + end ++ + case DelConflictRevs of + [] -> []; + _ -> [{"deleted_conflicts", list_to_tuple(DelConflictRevs)}] + end ++ + case Deleted of + true -> [{"deleted", true}]; + false -> [] + end + }, + FoldlFun(Id, UpdateSeq, Json, Offset, TotalRowCount, Acc) + end, {Count, SkipCount, undefined, []}), + finish_view_fold(Req, {ok, TotalRowCount, FoldResult}); + +handle_db_request(_Req, _Method, {_DbName, _Db, ["_all_docs_by_seq"]}) -> + throw({method_not_allowed, "GET,HEAD"}); + +handle_db_request(Req, 'GET', {DbName, _Db, ["_view", DocId, ViewName]}) -> + #view_query_args{ + start_key = StartKey, + count = Count, + skip = SkipCount, + direction = Dir, + start_docid = StartDocId + } = QueryArgs = parse_view_query(Req), + View = {DbName, "_design/" ++ DocId, ViewName}, + Start = {StartKey, StartDocId}, + FoldlFun = make_view_fold_fun(Req, QueryArgs), + FoldAccInit = {Count, SkipCount, undefined, []}, + FoldResult = couch_view:fold(View, Start, Dir, FoldlFun, FoldAccInit), + finish_view_fold(Req, FoldResult); + +handle_db_request(_Req, _Method, {_DbName, _Db, ["_view", _DocId, _ViewName]}) -> + throw({method_not_allowed, "GET,HEAD"}); + +handle_db_request(Req, 'POST', {_DbName, Db, ["_missing_revs"]}) -> + {obj, JsonDocIdRevs} = cjson:decode(Req:recv_body()), + DocIdRevs = [{Id, tuple_to_list(Revs)} || {Id, Revs} <- JsonDocIdRevs], + {ok, Results} = couch_db:get_missing_revs(Db, DocIdRevs), + JsonResults = [{Id, list_to_tuple(Revs)} || {Id, Revs} <- Results], + send_json(Req, {obj, [ + {missing_revs, {obj, JsonResults}} + ]}); + +handle_db_request(Req, 'POST', {DbName, _Db, ["_temp_view"]}) -> + #view_query_args{ + start_key = StartKey, + count = Count, + skip = SkipCount, + direction = Dir, + start_docid = StartDocId + } = QueryArgs = parse_view_query(Req), + + ContentType = case Req:get_primary_header_value("content-type") of + undefined -> + "text/javascript"; + Else -> + Else + end, + + View = {temp, DbName, ContentType, Req:recv_body()}, + Start = {StartKey, StartDocId}, + FoldlFun = make_view_fold_fun(Req, QueryArgs), + FoldAccInit = {Count, SkipCount, undefined, []}, + FoldResult = couch_view:fold(View, Start, Dir, FoldlFun, FoldAccInit), + finish_view_fold(Req, FoldResult); + +handle_db_request(_Req, _Method, {_DbName, _Db, ["_temp_view"]}) -> + throw({method_not_allowed, "POST"}); + +% Document request handlers + +handle_db_request(Req, Method, {DbName, Db, [DocId]}) -> + UnquotedDocId = mochiweb_util:unquote(DocId), + handle_doc_request(Req, Method, DbName, Db, UnquotedDocId); + +handle_db_request(Req, Method, {DbName, Db, [DocId, FileName]}) -> + UnquotedDocId = mochiweb_util:unquote(DocId), + UnquotedFileName = mochiweb_util:unquote(FileName), + handle_attachment_request(Req, Method, DbName, Db, UnquotedDocId, + UnquotedFileName). + +handle_doc_request(Req, 'DELETE', _DbName, Db, DocId) -> + QueryRev = proplists:get_value("rev", Req:parse_qs()), + Etag = case Req:get_header_value("If-Match") of + undefined -> + undefined; + Tag -> + string:strip(Tag, both, $") + end, + RevToDelete = case {QueryRev, Etag} of + {undefined, undefined} -> + throw({missing_rev, "Document rev/etag must be specified to delete"}); + {_, undefined} -> + QueryRev; + {undefined, _} -> + Etag; + _ when QueryRev == Etag -> + Etag; + _ -> + throw({bad_request, "Document rev and etag have different values"}) + end, + {ok, NewRev} = couch_db:delete_doc(Db, DocId, [RevToDelete]), + send_json(Req, 202, {obj, [ + {ok, true}, + {id, DocId}, + {rev, NewRev} + ]}); + +handle_doc_request(Req, 'GET', _DbName, Db, DocId) -> + #doc_query_args{ + rev = Rev, + open_revs = Revs, + options = Options + } = parse_doc_query(Req), + case Revs of + [] -> + case Rev of + "" -> + % open most recent rev + case couch_db:open_doc(Db, DocId, Options) of + {ok, #doc{revs=[DocRev|_]}=Doc} -> + Etag = none_match(Req, DocRev), + JsonDoc = couch_doc:to_json_obj(Doc, Options), + AdditionalHeaders = + case Doc#doc.meta of + [] -> [{"Etag", Etag}]; % output etag when we have no meta + _ -> [] + end, + send_json(Req, 200, AdditionalHeaders, JsonDoc); + Error -> + throw(Error) + end; + _ -> + % open a specific rev (deletions come back as stubs) + case couch_db:open_doc_revs(Db, DocId, [Rev], Options) of + {ok, [{ok, Doc}]} -> + send_json(Req, 200, [], + couch_doc:to_json_obj(Doc, Options)); + {ok, [Else]} -> + throw(Else) + end + end; + _ -> + {ok, Results} = couch_db:open_doc_revs(Db, DocId, Revs, Options), + Resp = start_json_response(Req, 200), + Resp:write_chunk("["), + % We loop through the docs. The first time through the separator + % is whitespace, then a comma on subsequent iterations. + lists:foldl( + fun(Result, AccSeparator) -> + case Result of + {ok, Doc} -> + JsonDoc = couch_doc:to_json_obj(Doc, Options), + Json = lists:flatten(cjson:encode({obj, [{ok, JsonDoc}]})), + Resp:write_chunk(AccSeparator ++ Json); + {{not_found, missing}, RevId} -> + Json = {obj, [{"missing", RevId}]}, + Json = lists:flatten(cjson:encode(Json)), + Resp:write_chunk(AccSeparator ++ Json) + end, + "," % AccSeparator now has a comma + end, + "", Results), + Resp:write_chunk("]"), + end_json_response(Resp) + end; + +handle_doc_request(Req, 'PUT', _DbName, Db, DocId) -> + Json = {obj, DocProps} = cjson:decode(Req:recv_body()), + DocRev = proplists:get_value("_rev", DocProps), + Etag = case Req:get_header_value("If-Match") of + undefined -> + undefined; + Tag -> + string:strip(Tag, both, $") + end, + Revs = case {DocRev, Etag} of + {undefined, undefined} -> + []; + {_, undefined} -> + [DocRev]; + {undefined, _} -> + [Etag]; + _ when DocRev == Etag -> + [Etag]; + _ -> + throw({bad_request, "Document rev and etag have different values"}) + end, + + Doc = couch_doc:from_json_obj(Json), + + {ok, NewRev} = couch_db:update_doc(Db, Doc#doc{id=DocId, revs=Revs}, []), + send_json(Req, 201, [{"Etag", "\"" ++ NewRev ++ "\""}], {obj, [ + {ok, true}, + {id, DocId}, + {rev, NewRev} + ]}); + +handle_doc_request(_Req, _Method, _DbName, _Db, _DocId) -> + throw({method_not_allowed, "DELETE,GET,HEAD,PUT"}). + +% Attachment request handlers + +handle_attachment_request(Req, 'GET', _DbName, Db, DocId, FileName) -> + case couch_db:open_doc(Db, DocId, []) of + {ok, #doc{attachments=Attachments}} -> + case proplists:get_value(FileName, Attachments) of + undefined -> + throw({not_found, missing}); + {Type, Bin} -> + Resp = Req:respond({200, [ + {"content-type", Type}, + {"content-length", integer_to_list(couch_doc:bin_size(Bin))} + ], chunked}), + couch_doc:bin_foldl(Bin, + fun(BinSegment, []) -> + ok = Resp:write_chunk(BinSegment), + {ok, []} + end, + [] + ), + Resp:write_chunk(""), + {ok, Resp} + end; + Error -> + throw(Error) + end; + +handle_attachment_request(_Req, _Method, _DbName, _Db, _DocId, _FileName) -> + throw({method_not_allowed, "GET,HEAD"}). + +% View request handling internals + +reverse_key_default(nil) -> <<>>; +reverse_key_default(<<>>) -> nil; +reverse_key_default(Key) -> Key. + +parse_view_query(Req) -> + QueryList = Req:parse_qs(), + lists:foldl(fun({Key,Value}, Args) -> + case {Key, Value} of + {"", _} -> + Args; + {"key", Value} -> + JsonKey = cjson:decode(Value), + Args#view_query_args{start_key=JsonKey,end_key=JsonKey}; + {"startkey_docid", DocId} -> + Args#view_query_args{start_docid=DocId}; + {"startkey", Value} -> + Args#view_query_args{start_key=cjson:decode(Value)}; + {"endkey", Value} -> + Args#view_query_args{end_key=cjson:decode(Value)}; + {"count", Value} -> + case (catch list_to_integer(Value)) of + Count when is_integer(Count) -> + if Count < 0 -> + Args#view_query_args { + direction = + if Args#view_query_args.direction == rev -> fwd; + true -> rev + end, + count=Count, + start_key = reverse_key_default(Args#view_query_args.start_key), + start_docid = reverse_key_default(Args#view_query_args.start_docid), + end_key = reverse_key_default(Args#view_query_args.end_key), + end_docid = reverse_key_default(Args#view_query_args.end_docid)}; + true -> + Args#view_query_args{count=Count} + end; + _Error -> + Msg = io_lib:format("Bad URL query value, number expected: count=~s", [Value]), + throw({query_parse_error, Msg}) + end; + {"update", "false"} -> + Args#view_query_args{update=false}; + {"descending", "true"} -> + case Args#view_query_args.direction of + fwd -> + Args#view_query_args { + direction = rev, + start_key = reverse_key_default(Args#view_query_args.start_key), + start_docid = reverse_key_default(Args#view_query_args.start_docid), + end_key = reverse_key_default(Args#view_query_args.end_key), + end_docid = reverse_key_default(Args#view_query_args.end_docid)}; + _ -> + Args %already reversed + end; + {"skip", Value} -> + case (catch list_to_integer(Value)) of + Count when is_integer(Count) -> + Args#view_query_args{skip=Count}; + _Error -> + Msg = lists:flatten(io_lib:format( + "Bad URL query value, number expected: skip=~s", [Value])), + throw({query_parse_error, Msg}) + end; + _ -> % unknown key + Msg = lists:flatten(io_lib:format( + "Bad URL query key:~s", [Key])), + throw({query_parse_error, Msg}) + end + end, #view_query_args{}, QueryList). + +make_view_fold_fun(Req, QueryArgs) -> + #view_query_args{ + end_key = EndKey, + end_docid = EndDocId, + direction = Dir, + count = Count + } = QueryArgs, + + PassedEndFun = case Dir of + fwd -> + fun(ViewKey, ViewId) -> + couch_view:less_json({EndKey, EndDocId}, {ViewKey, ViewId}) + end; + rev-> + fun(ViewKey, ViewId) -> + couch_view:less_json({ViewKey, ViewId}, {EndKey, EndDocId}) + end + end, + + NegCountFun = fun(Id, Key, Value, Offset, TotalViewCount, + {AccCount, AccSkip, Resp, AccRevRows}) -> + PassedEnd = PassedEndFun(Key, Id), + case {PassedEnd, AccCount, AccSkip, Resp} of + {true, _, _, _} -> % The stop key has been passed, stop looping. + {stop, {AccCount, AccSkip, Resp, AccRevRows}}; + {_, 0, _, _} -> % we've done "count" rows, stop foldling + {stop, {0, 0, Resp, AccRevRows}}; + {_, _, AccSkip, _} when AccSkip > 0 -> + {ok, {AccCount, AccSkip - 1, Resp, AccRevRows}}; + {_, _, _, undefined} -> + Resp2 = start_json_response(Req, 200), + Offset2 = TotalViewCount - Offset - + lists:min([TotalViewCount - Offset, - AccCount]), + JsonBegin = io_lib:format("{\"total_rows\":~w,\"offset\":~w,\"rows\":[", + [TotalViewCount, Offset2]), + Resp2:write_chunk(lists:flatten(JsonBegin)), + JsonObj = {obj, [{id, Id}, {key, Key}, {value, Value}]}, + {ok, {AccCount + 1, 0, Resp2, [cjson:encode(JsonObj) | AccRevRows]}}; + {_, AccCount, _, Resp} -> + JsonObj = {obj, [{id, Id}, {key, Key}, {value, Value}]}, + {ok, {AccCount + 1, 0, Resp, [cjson:encode(JsonObj), "," | AccRevRows]}} + end + end, + + PosCountFun = fun(Id, Key, Value, Offset, TotalViewCount, + {AccCount, AccSkip, Resp, AccRevRows}) -> + PassedEnd = PassedEndFun(Key, Id), + case {PassedEnd, AccCount, AccSkip, Resp} of + {true, _, _, _} -> + % The stop key has been passed, stop looping. + {stop, {AccCount, AccSkip, Resp, AccRevRows}}; + {_, 0, _, _} -> + % we've done "count" rows, stop foldling + {stop, {0, 0, Resp, AccRevRows}}; + {_, _, AccSkip, _} when AccSkip > 0 -> + {ok, {AccCount, AccSkip - 1, Resp, AccRevRows}}; + {_, _, _, undefined} -> + Resp2 = start_json_response(Req, 200), + JsonBegin = io_lib:format("{\"total_rows\":~w,\"offset\":~w,\"rows\":[\r\n", + [TotalViewCount, Offset]), + JsonObj = {obj, [{id, Id}, {key, Key}, {value, Value}]}, + Resp2:write_chunk(lists:flatten(JsonBegin ++ cjson:encode(JsonObj))), + {ok, {AccCount - 1, 0, Resp2, AccRevRows}}; + {_, AccCount, _, Resp} when (AccCount > 0) -> + JsonObj = {obj, [{"id", Id}, {"key", Key}, {"value", Value}]}, + Resp:write_chunk(",\r\n" ++ lists:flatten(cjson:encode(JsonObj))), + {ok, {AccCount - 1, 0, Resp, AccRevRows}} + end + end, + case Count > 0 of + true -> PosCountFun; + false -> NegCountFun + end. + +finish_view_fold(Req, FoldResult) -> + case FoldResult of + {ok, TotalRows, {_, _, undefined, _}} -> + % nothing found in the view, nothing has been returned + % send empty view + send_json(Req, 200, {obj, [ + {total_rows, TotalRows}, + {rows, []} + ]}); + {ok, _TotalRows, {_, _, Resp, AccRevRows}} -> + % end the view + Resp:write_chunk(lists:flatten(AccRevRows) ++ "\r\n]}"), + end_json_response(Resp); + Error -> + throw(Error) + end. + +% Document request handling internals + +parse_doc_query(Req) -> + lists:foldl(fun({Key,Value}, Args) -> + case {Key, Value} of + {"attachments", "true"} -> + Options = [attachments | Args#doc_query_args.options], + Args#doc_query_args{options=Options}; + {"meta", "true"} -> + Options = [revs_info, conflicts, deleted_conflicts | Args#doc_query_args.options], + Args#doc_query_args{options=Options}; + {"revs", "true"} -> + Options = [revs | Args#doc_query_args.options], + Args#doc_query_args{options=Options}; + {"revs_info", "true"} -> + Options = [revs_info | Args#doc_query_args.options], + Args#doc_query_args{options=Options}; + {"conflicts", "true"} -> + Options = [conflicts | Args#doc_query_args.options], + Args#doc_query_args{options=Options}; + {"deleted_conflicts", "true"} -> + Options = [deleted_conflicts | Args#doc_query_args.options], + Args#doc_query_args{options=Options}; + {"rev", Rev} -> + Args#doc_query_args{rev=Rev}; + {"open_revs", "all"} -> + Args#doc_query_args{open_revs=all}; + {"open_revs", RevsJsonStr} -> + JsonArray = cjson:decode(RevsJsonStr), + Args#doc_query_args{open_revs=tuple_to_list(JsonArray)}; + _Else -> % unknown key value pair, ignore. + Args + end + end, #doc_query_args{}, Req:parse_qs()). + +% Utilities + +none_match(Req, Tag) -> + Etag = "\"" ++ Tag ++ "\"", + Etags = case Req:get_header_value("If-None-Match") of + undefined -> + []; + Tags -> + string:tokens(Tags, ", ") + end, + case lists:member(Etag, Etags) of + true -> + throw({not_modified, Etag}); + false -> + Etag + end. + +error_to_json(Error) -> + {HttpCode, Atom, Reason} = error_to_json0(Error), + FormattedReason = + case (catch io_lib:format("~s", [Reason])) of + List when is_list(List) -> + lists:flatten(List); + _ -> + lists:flatten(io_lib:format("~p", [Reason])) % else term to text + end, + Json = {obj, [ + {error, atom_to_list(Atom)}, + {reason, FormattedReason} + ]}, + {HttpCode, Json}. + +error_to_json0(bad_request) -> + {400, bad_request, "Bad request"}; +error_to_json0({bad_request, Reason}) -> + {400, bad_request, Reason}; +error_to_json0(not_found) -> + {404, not_found, "missing"}; +error_to_json0({missing_rev, Msg}) -> + {412, missing_rev, Msg}; +error_to_json0({not_found, Reason}) -> + {404, not_found, Reason}; +error_to_json0({database_already_exists, Reason}) -> + {409, database_already_exists, Reason}; +error_to_json0(conflict) -> + {412, conflict, "Update conflict"}; +error_to_json0({doc_validation, Msg}) -> + {406, doc_validation, Msg}; +error_to_json0({Id, Reason}) when is_atom(Id) -> + {500, Id, Reason}; +error_to_json0(Error) -> + {500, error, Error}. + +send_error(Req, {method_not_allowed, Methods}) -> + {ok, Req:respond({405, [{"Allow", Methods}], <<>>})}; +send_error(Req, {modified, Etag}) -> + {ok, Req:respond({412, [{"Etag", Etag}], <<>>})}; +send_error(Req, {not_modified, Etag}) -> + {ok, Req:respond({304, [{"Etag", Etag}], <<>>})}; +send_error(Req, Error) -> + {Code, Json} = error_to_json(Error), + couch_log:info("HTTP Error (code ~w): ~p", [Code, Error]), + send_error(Req, Code, Json). + +send_error(Req, Code, Json) -> + send_json(Req, Code, Json). + +send_json(Req, Value) -> + send_json(Req, 200, Value). + +send_json(Req, Code, Value) -> + send_json(Req, Code, [], Value). + +send_json(Req, Code, Headers, Value) -> + Resp = start_json_response(Req, Code, Headers), + Resp:write_chunk(cjson:encode(Value)), + end_json_response(Resp), + {ok, Resp}. + +start_json_response(Req, Code) -> + start_json_response(Req, Code, []). + +start_json_response(Req, Code, Headers) -> + AcceptedTypes = case Req:get_header_value("Accept") of + undefined -> []; + AcceptHeader -> string:tokens(AcceptHeader, ", ") + end, + ContentType = case lists:member("application/json", AcceptedTypes) of + true -> "application/json"; + false -> "text/plain;charset=utf-8" + end, + Req:respond({Code, [{"Content-Type", ContentType}] ++ Headers, chunked}). + +end_json_response(Resp) -> + Resp:write_chunk(""), + {ok, Resp}. diff --git a/src/couchdb/couch_rep.erl b/src/couchdb/couch_rep.erl index 4a6a415a..3b338e6e 100644 --- a/src/couchdb/couch_rep.erl +++ b/src/couchdb/couch_rep.erl @@ -154,6 +154,15 @@ do_http_request(Url, Action, JsonBody) -> couch_log:debug("couch_rep HTTP client request:"), couch_log:debug("\tAction: ~p", [Action]), couch_log:debug("\tUrl: ~p", [Url]), + + % ensure that the inets application is running + case application:start(inets) of + ok -> + ok; + {error, {already_started, inets}} -> + ok + end, + Request = case JsonBody of [] -> diff --git a/src/couchdb/couch_server_sup.erl b/src/couchdb/couch_server_sup.erl index 3c9b92f6..9c751f9c 100644 --- a/src/couchdb/couch_server_sup.erl +++ b/src/couchdb/couch_server_sup.erl @@ -65,7 +65,9 @@ start_server(InputIniFilename) -> ConsoleStartupMsg = proplists:get_value({"Couch", "ConsoleStartupMsg"}, Ini, "Apache CouchDB is starting."), LogLevel = list_to_atom(proplists:get_value({"Couch", "LogLevel"}, Ini, "error")), DbRootDir = proplists:get_value({"Couch", "DbRootDir"}, Ini, "."), - HttpConfigFile = proplists:get_value({"Couch", "HttpConfigFile"}, Ini, "couch_httpd.conf"), + BindAddress = proplists:get_value({"Couch", "BindAddress"}, Ini, any), + Port = proplists:get_value({"Couch", "Port"}, Ini, 5984), + DocumentRoot = proplists:get_value({"Couch", "DocumentRoot"}, Ini, "share/www"), LogFile = proplists:get_value({"Couch", "LogFile"}, Ini, "couchdb.log"), UtilDriverDir = proplists:get_value({"Couch", "UtilDriverDir"}, Ini, ""), UpdateNotifierExes = proplists:get_all_values({"Couch", "DbUpdateNotificationProcess"}, Ini), @@ -111,12 +113,12 @@ start_server(InputIniFilename) -> brutal_kill, worker, [couch_view]}, - {httpd, - {httpd, start_link, [HttpConfigFile]}, + {couch_httpd, + {couch_httpd, start_link, [BindAddress, Port, DocumentRoot]}, permanent, 1000, supervisor, - [httpd]} + [couch_httpd]} ] ++ lists:map(fun(UpdateNotifierExe) -> {UpdateNotifierExe, @@ -148,7 +150,9 @@ start_server(InputIniFilename) -> ConfigInfo = io_lib:format("Config Info ~s:~n\tCurrentWorkingDir=~s~n" ++ "\tDbRootDir=~s~n" ++ - "\tHttpConfigFile=~s~n" ++ + "\tBindAddress=~p~n" ++ + "\tPort=~p~n" ++ + "\tDocumentRoot=~s~n" ++ "\tLogFile=~s~n" ++ "\tUtilDriverDir=~s~n" ++ "\tDbUpdateNotificationProcesses=~s~n" ++ @@ -157,7 +161,9 @@ start_server(InputIniFilename) -> [IniFilename, Cwd, DbRootDir, - HttpConfigFile, + BindAddress, + Port, + DocumentRoot, LogFile, UtilDriverDir, UpdateNotifierExes, diff --git a/src/couchdb/mod_couch.erl b/src/couchdb/mod_couch.erl deleted file mode 100644 index 0d157b1e..00000000 --- a/src/couchdb/mod_couch.erl +++ /dev/null @@ -1,890 +0,0 @@ -% Licensed under the Apache License, Version 2.0 (the "License"); you may not -% use this file except in compliance with the License. You may obtain a copy of -% the License at -% -% http://www.apache.org/licenses/LICENSE-2.0 -% -% Unless required by applicable law or agreed to in writing, software -% distributed under the License is distributed on an "AS IS" BASIS, WITHOUT -% WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the -% License for the specific language governing permissions and limitations under -% the License. - --module(mod_couch). - --include("couch_db.hrl"). - --export([do/1, load/2, url_decode/1]). - --include_lib("../couch_inets/httpd.hrl"). - --record(uri_parts, - {db = "", - doc = "", - attachment = "", - view = "", - querystr = ""}). - --record(doc_query_args, - { - options = [], - rev = "", - open_revs = "" - }). - -%% do. This is the main entry point into Apache CouchDB from the HTTP server - -do(Mod) -> - #mod{request_uri=Uri,request_line=Request, parsed_header=Header,entity_body=Body} = Mod, - PrevTrapExit = process_flag(trap_exit, true), - Resp = - case Uri of - "/_utils/" ++ RestURI -> - % if the URI is the utils directory, then this - % tells mod_get (a std HTTP module) where to serve the file from - DocumentRoot = httpd_util:lookup(Mod#mod.config_db, document_root, ""), - {Path, AfterPath} = httpd_util:split_path(DocumentRoot ++ "/" ++ RestURI), - - case RestURI of - "" -> - Paths = httpd_util:split_path(DocumentRoot ++ "/index.html"), - {proceed, [{real_name, Paths} | Mod#mod.data]}; - _ -> - case filelib:is_file(Path) of - true -> - {proceed, [{real_name, {Path, AfterPath}} | Mod#mod.data]}; - false -> - case filelib:is_dir(Path) of - true -> - % this ends up causing a "Internal Server Error", need to fix. - {proceed, [{response,{403,"Forbidden"}}]}; - false -> - {proceed, [{response,{404,"Not found"}}]} - end - end - end; - "/favicon.ico" -> - DocumentRoot = httpd_util:lookup(Mod#mod.config_db, document_root, ""), - RealName = DocumentRoot ++ "/" ++ Uri, - {Path, AfterPath} = httpd_util:split_path(RealName), - {proceed, [{real_name, {Path, AfterPath}} | Mod#mod.data]}; - _ -> - couch_log:info("HTTP Request: ~s", [Request]), - couch_log:debug("Headers: ~p", [Header]), - couch_log:debug("Body: ~P", [Body, 100]), - case (catch parse_uri(Uri)) of - {ok, Parts} -> - {ok, ResponseCode} = - case (catch do(Mod, Parts)) of - {ok, ResponseCode0} -> - {ok, ResponseCode0}; - Error -> - send_error(Mod, Error) - end; - Error -> - {ok, ResponseCode} = send_error(Mod, Error) - end, - couch_log:info("HTTP Response Code:~p~n", [ResponseCode]), - {proceed, [{response, {already_sent, ResponseCode, 0}} | Mod#mod.data]} - end, - process_flag(trap_exit, PrevTrapExit), - Resp. - - -parse_uri(RequestUri) -> - % seperate out the path and query portions and - % strip out leading slash and question mark. - case regexp:split(RequestUri, "\\?") of - {ok, [[$/|UriPath], QueryStr]} -> ok; - {ok, [[$/|UriPath]]} -> QueryStr = "" - end, - % lets try to parse out the UriPath. - {ok, UrlParts} = regexp:split(UriPath, "/"), - - {DbName, Id, Attachment, View} = - case UrlParts of - [Db] -> - {Db, "", "", ""}; - [Db, "_design", Doc] -> - {Db, "_design/" ++ Doc, "", ""}; - [Db, "_design", Doc, Attachment0] -> - {Db, "_design/" ++ Doc, Attachment0, ""}; - [Db, "_view", Doc, ViewName] -> - {Db, "_design/" ++ Doc, "", ViewName}; - [Db, "_view%2f" ++ Doc, ViewName] -> - {Db, "_design/" ++ Doc, "", ViewName}; - [Db, Doc] -> - {Db, Doc, "", ""}; - [Db, Doc, Attachment0] -> - {Db, Doc, Attachment0, ""}; - _ -> - throw({invalid_uri, lists:flatten(io_lib:format("Uri has too many parts: ~p", [UrlParts]))}) - end, - {ok, #uri_parts{db=url_decode(DbName), - doc=url_decode(Id), - attachment=url_decode(Attachment), - view=url_decode(View), - querystr=url_decode(QueryStr)}}. - -resp_json_header(Mod) -> - resp_json_header(Mod, []). - -% return json doc header values list -resp_json_header(Mod, Options) -> - Types = string:tokens(proplists:get_value("accept", Mod#mod.parsed_header, ""), ", "), - case lists:member("application/json", Types) of - true -> - resp_header(Mod, Options) ++ [{"content-type","application/json"}]; - false -> - resp_header(Mod, Options) ++ [{"content-type","text/plain;charset=utf-8"}] - end. - -% return doc header values list -resp_header(#mod{http_version=Version}, Options) -> - [{"cache-control", "no-cache"}, - {"pragma", "no-cache"}, - {"expires", httpd_util:rfc1123_date()}] ++ - case lists:member(no_body, Options) of - true -> []; - false -> - case Version == "HTTP/1.1" of - true -> - [{"transfer-encoding", "chunked"}]; - false -> - [{"connection", "close"}] - end - end. - - -url_decode([$%, Hi, Lo | Tail]) -> - Hex = erlang:list_to_integer([Hi, Lo], 16), - xmerl_ucs:to_utf8([Hex]) ++ url_decode(Tail); -url_decode([H|T]) -> - [H |url_decode(T)]; -url_decode([]) -> - []. - - -send_header(Mod, RespCode, Headers) -> - couch_log:debug("HTTP Response Headers (code ~w): ~p", [RespCode, Headers]), - httpd_response:send_header(Mod, RespCode, Headers). - -send_chunk(Mod, Data) -> - httpd_response:send_chunk(Mod, Data, false). - -send_final_chunk(Mod) -> - httpd_response:send_final_chunk(Mod, false). - -show_couch_welcome(Mod) -> - send_header(Mod, 200, resp_json_header(Mod)), - send_chunk(Mod, "{\"couchdb\": \"Welcome\", "), - send_chunk(Mod, "\"version\": \"" ++ couch_server:get_version()), - send_chunk(Mod, "\"}\n"), - send_final_chunk(Mod), - {ok, 200}. - - -do(#mod{method="GET"}=Mod, #uri_parts{db=""}) -> - show_couch_welcome(Mod); -do(#mod{method="GET"}=Mod, #uri_parts{db="_all_dbs", doc=""}=Parts) -> - send_all_dbs(Mod, Parts); -do(#mod{method="POST"}=Mod, #uri_parts{db="_replicate", doc=""}) -> - handle_replication_request(Mod); -do(#mod{method="POST"}=Mod, #uri_parts{db="_restart", doc=""}) -> - couch_server:remote_restart(), - send_ok(Mod, 201); -do(#mod{method="POST"}=Mod, #uri_parts{doc="_missing_revs"}=Parts) -> - handle_missing_revs_request(Mod, Parts); -do(#mod{method="POST"}=Mod, #uri_parts{doc="_compact"}=Parts) -> - handle_compact(Mod, Parts); -do(#mod{method="PUT"}=Mod, #uri_parts{doc=""}=Parts) -> - handle_db_create(Mod, Parts); -do(#mod{method="DELETE"}=Mod, #uri_parts{doc=""}=Parts) -> - handle_db_delete(Mod, Parts); -do(#mod{method="POST"}=Mod, #uri_parts{doc="_bulk_docs"}=Parts) -> - handle_bulk_doc_update(Mod, Parts); -do(#mod{method="POST"}=Mod, #uri_parts{doc=""}=Parts) -> - handle_doc_post(Mod, Parts); -do(#mod{method="PUT"}=Mod, Parts) -> - handle_doc_put(Mod, Parts); -do(#mod{method="DELETE"}=Mod, Parts) -> - handle_doc_delete(Mod, Parts); -do(#mod{method="POST"}=Mod, #uri_parts{doc="_temp_view"}=Parts) -> - send_temp_view(Mod, Parts); -do(#mod{method="GET"}=Mod, #uri_parts{doc="_all_docs"}=Parts) -> - send_all_docs(Mod, Parts); -do(#mod{method="GET"}=Mod, #uri_parts{doc="_all_docs_by_seq"}=Parts) -> - send_all_docs_by_seq(Mod, Parts); -do(#mod{method="GET"}=Mod, #uri_parts{doc=""}=Parts) -> - send_database_info(Mod, Parts); -do(#mod{method=Method}=Mod, #uri_parts{attachment="",view=""}=Parts) - when Method == "GET" orelse Method == "HEAD" -> - #doc_query_args{open_revs=Revs} = doc_parse_query(Parts#uri_parts.querystr), - case Revs of - [] -> - send_doc(Mod, Parts); - _ -> - send_doc_revs(Mod, Parts) - end; -do(#mod{method=Method}=Mod, #uri_parts{attachment=Att}=Parts) - when Att /= "", Method == "GET" orelse Method == "HEAD" -> - send_attachment(Mod, Parts); -do(#mod{method="GET"}=Mod, #uri_parts{view=View}=Parts) when View /= "" -> - send_view(Mod, Parts). - -handle_db_create(Mod, #uri_parts{db=DbName}) -> - case couch_server:create(DbName, []) of - {ok, _Db} -> - send_ok(Mod, 201); - {error, database_already_exists} -> - Msg = io_lib:format("Database ~p already exists.", [DbName]), - throw({database_already_exists, Msg}); - Error -> - Msg = io_lib:format("Error creating database ~p: ~p", [DbName, Error]), - throw({unknown_error, Msg}) - end. - -handle_db_delete(Mod, #uri_parts{db=DbName}) -> - % delete with no doc specified, therefore database delete - case couch_server:delete(DbName) of - ok -> - send_ok(Mod, 202); - Error -> - throw(Error) - end. - -handle_bulk_doc_update(#mod{entity_body=RawBody}=Mod, Parts) -> - Options = [], % put options here. - Db = open_db(Parts), - {obj, JsonProps} = cjson:decode(RawBody), - DocsArray = proplists:get_value("docs", JsonProps), - % convert all the doc elements to native docs - case proplists:get_value("new_edits", JsonProps, true) of - true -> - Docs = lists:map( - fun({obj, ObjProps} = JsonObj) -> - Doc = couch_doc:from_json_obj(JsonObj), - - Id = - case Doc#doc.id of - "" -> couch_util:new_uuid(); - Id0 -> Id0 - end, - Revs = - case proplists:get_value("_rev", ObjProps) of - undefined -> []; - Rev -> [Rev] - end, - Doc#doc{id=Id,revs=Revs} - end, - tuple_to_list(DocsArray)), - - {ok, ResultRevs} = couch_db:update_docs(Db, Docs, Options), - - % output the results - DocResults = lists:zipwith( - fun(Doc, NewRev) -> - {obj, [{"id", Doc#doc.id}, {"rev", NewRev}]} - end, - Docs, ResultRevs), - send_ok(Mod, 201, [{new_revs, list_to_tuple(DocResults)}]); - - false -> - Docs = [couch_doc:from_json_obj(JsonObj) || JsonObj <- tuple_to_list(DocsArray)], - ok = couch_db:save_docs(Db, Docs, Options), - send_ok(Mod, 201) - end. - - - - -doc_parse_query(QueryStr) -> - QueryList = httpd:parse_query(QueryStr), - lists:foldl(fun({Key,Value}, Args) -> - case {Key, Value} of - {"attachments", "true"} -> - Options = [attachments | Args#doc_query_args.options], - Args#doc_query_args{options=Options}; - {"meta", "true"} -> - Options = [revs_info, conflicts, deleted_conflicts | Args#doc_query_args.options], - Args#doc_query_args{options=Options}; - {"revs", "true"} -> - Options = [revs | Args#doc_query_args.options], - Args#doc_query_args{options=Options}; - {"revs_info", "true"} -> - Options = [revs_info | Args#doc_query_args.options], - Args#doc_query_args{options=Options}; - {"conflicts", "true"} -> - Options = [conflicts | Args#doc_query_args.options], - Args#doc_query_args{options=Options}; - {"deleted_conflicts", "true"} -> - Options = [deleted_conflicts | Args#doc_query_args.options], - Args#doc_query_args{options=Options}; - {"rev", Rev} -> - Args#doc_query_args{rev=Rev}; - {"open_revs", "all"} -> - Args#doc_query_args{open_revs=all}; - {"open_revs", RevsJsonStr} -> - JsonArray = cjson:decode(RevsJsonStr), - Args#doc_query_args{open_revs=tuple_to_list(JsonArray)}; - _Else -> % unknown key value pair, ignore. - Args - end - end, - #doc_query_args{}, QueryList). - - -handle_doc_post(#mod{entity_body=RawBody}=Mod, Parts) -> - Db = open_db(Parts), - Json = cjson:decode(RawBody), - Doc = couch_doc:from_json_obj(Json), - Id = couch_util:new_uuid(), - {ok, NewRevId} = couch_db:update_doc(Db, Doc#doc{id=Id, revs=[]}, []), - send_ok(Mod, 201, [{"id", Id}, {"rev", NewRevId}], [{"etag", NewRevId}]). - -handle_doc_put(#mod{parsed_header=Headers}=Mod, - #uri_parts{doc=Id, querystr=QueryStr}=Parts) -> - #doc_query_args{options=SaveOptions} = doc_parse_query(QueryStr), - Db = open_db(Parts), - {obj, ObjProps} = Json = cjson:decode(Mod#mod.entity_body), - Doc = couch_doc:from_json_obj(Json), - Etag = proplists:get_value("if-match", Headers, ""), - DocRev = proplists:get_value("_rev", ObjProps, ""), - - if DocRev /= "" andalso Etag /= "" andalso DocRev /= Etag -> - throw({invalid_request, "Document rev and etag have different values"}); - true -> ok - end, - Revs = - if DocRev /= "" -> [DocRev]; - Etag /= "" -> [Etag]; - true -> [] - end, - - {ok, NewRevId} = couch_db:update_doc(Db, Doc#doc{id=Id, revs=Revs}, SaveOptions), - send_ok(Mod, 201, [{"id", Id}, {"rev", NewRevId}],[{"etag", NewRevId}]). - -handle_doc_delete(#mod{parsed_header=Headers}=Mod, - #uri_parts{doc=Id, querystr=QueryStr}=Parts) -> - Db = open_db(Parts), - #doc_query_args{rev=QueryRev} = doc_parse_query(QueryStr), - Etag = proplists:get_value("if-match", Headers, ""), - RevToDelete = - case {QueryRev, Etag} of - {"", ""} -> - throw({missing_rev, "Document rev/etag must be specified to delete"}); - {_, ""} -> - QueryRev; - {"", _} -> - Etag; - _ when QueryRev == Etag -> - Etag; - _ -> - throw({invalid_request, "Document rev and etag have different values"}) - end, - {ok, NewRev} = couch_db:delete_doc(Db, Id, [RevToDelete]), - send_ok(Mod, 202, [{"id", Id}, {"rev", NewRev}]). - - --record(query_args, - {start_key = nil, - end_key = <<>>, - count = 10000000000, % a huge huge default number. Picked so we don't have - % to do different logic for when there is no count limit - update = true, - direction = fwd, - start_docid = nil, - end_docid = <<>>, - skip = 0 - }). - -reverse_key_default(nil) -> <<>>; -reverse_key_default(<<>>) -> nil; -reverse_key_default(Key) -> Key. - -view_parse_query(QueryStr) -> - QueryList = httpd:parse_query(QueryStr), - lists:foldl(fun({Key,Value}, Args) -> - case {Key, Value} of - {"", _} -> - Args; - {"key", Value} -> - JsonKey = cjson:decode(Value), - Args#query_args{start_key=JsonKey,end_key=JsonKey}; - {"startkey_docid", DocId} -> - Args#query_args{start_docid=DocId}; - {"startkey", Value} -> - Args#query_args{start_key=cjson:decode(Value)}; - {"endkey", Value} -> - Args#query_args{end_key=cjson:decode(Value)}; - {"count", Value} -> - case (catch list_to_integer(Value)) of - Count when is_integer(Count) -> - if Count < 0 -> - Args#query_args { - direction = - if Args#query_args.direction == rev -> fwd; - true -> rev - end, - count=Count, - start_key = reverse_key_default(Args#query_args.start_key), - start_docid = reverse_key_default(Args#query_args.start_docid), - end_key = reverse_key_default(Args#query_args.end_key), - end_docid = reverse_key_default(Args#query_args.end_docid)}; - true -> - Args#query_args{count=Count} - end; - _Error -> - Msg = io_lib:format("Bad URL query value, number expected: count=~s", [Value]), - throw({query_parse_error, Msg}) - end; - {"update", "false"} -> - Args#query_args{update=false}; - {"descending", "true"} -> - case Args#query_args.direction of - fwd -> - Args#query_args { - direction = rev, - start_key = reverse_key_default(Args#query_args.start_key), - start_docid = reverse_key_default(Args#query_args.start_docid), - end_key = reverse_key_default(Args#query_args.end_key), - end_docid = reverse_key_default(Args#query_args.end_docid)}; - _ -> - Args %already reversed - end; - {"skip", Value} -> - case (catch list_to_integer(Value)) of - Count when is_integer(Count) -> - Args#query_args{skip=Count}; - _Error -> - Msg = lists:flatten(io_lib:format( - "Bad URL query value, number expected: skip=~s", [Value])), - throw({query_parse_error, Msg}) - end; - _ -> % unknown key - Msg = lists:flatten(io_lib:format( - "Bad URL query key:~s", [Key])), - throw({query_parse_error, Msg}) - end - end, - #query_args{}, QueryList). - - -% returns db, otherwise throws exception. Note: no {ok,_}. -open_db(#uri_parts{db=DbName}) -> - open_db(DbName); -open_db(DbName) when is_list(DbName)-> - case couch_server:open(DbName) of - {ok, Db} -> - Db; - Error -> - throw(Error) - end. - -handle_missing_revs_request(#mod{entity_body=RawJson}=Mod, Parts) -> - Db = open_db(Parts), - {obj, JsonDocIdRevs} = cjson:decode(RawJson), - DocIdRevs = [{Id, tuple_to_list(Revs)} || {Id, Revs} <- JsonDocIdRevs], - {ok, Results} = couch_db:get_missing_revs(Db, DocIdRevs), - JsonResults = [{Id, list_to_tuple(Revs)} || {Id, Revs} <- Results], - send_json(Mod, 200, {obj, [{missing_revs, {obj, JsonResults}}]}). - -handle_compact(Mod, Parts) -> - ok = couch_db:start_compact(open_db(Parts)), - send_ok(Mod, 202). - -handle_replication_request(#mod{entity_body=RawJson}=Mod) -> - {obj, Props} = cjson:decode(RawJson), - Src = proplists:get_value("source", Props), - Tgt = proplists:get_value("target", Props), - {obj, Options} = proplists:get_value("options", Props, {obj, []}), - {ok, {obj, JsonResults}} = couch_rep:replicate(Src, Tgt, Options), - send_ok(Mod, 200, JsonResults). - - - -send_database_info(Mod, #uri_parts{db=DbName}=Parts) -> - Db = open_db(Parts), - {ok, InfoList} = couch_db:get_db_info(Db), - send_json(Mod, 200, {obj, [{db_name, DbName} | InfoList]}). - -send_doc(#mod{parsed_header=Headers}=Mod, - #uri_parts{doc=DocId,querystr=QueryStr}=Parts) -> - Db = open_db(Parts), - #doc_query_args{rev=Rev, options=Options} = doc_parse_query(QueryStr), - case Rev of - "" -> - % open most recent rev - case couch_db:open_doc(Db, DocId, Options) of - {ok, #doc{revs=[DocRev|_]}=Doc} -> - Etag = proplists:get_value("if-none-match", Headers), - if Options == [] andalso Etag == DocRev -> - ok = send_header(Mod, 304, - resp_header(Mod, [no_body]) ++ [{"etag", DocRev}]), - {ok, 304}; - true -> - send_json(Mod, 200, couch_doc:to_json_obj(Doc, Options), - if Options == [] -> [{"etag", DocRev}]; true -> [] end) - end; - Error -> - throw(Error) - end; - _ -> - % open a specific rev (deletions come back as stubs) - case couch_db:open_doc_revs(Db, DocId, [Rev], Options) of - {ok, [{ok, Doc}]} -> - send_json(Mod, 200, couch_doc:to_json_obj(Doc, Options), [{"etag", Rev}]); - {ok, [Else]} -> - throw(Else) - end - end. - -send_doc_revs(Mod, #uri_parts{doc=DocId,querystr=QueryStr}=Parts) -> - Db = open_db(Parts), - #doc_query_args{options=Options, open_revs=Revs} = doc_parse_query(QueryStr), - {ok, Results} = couch_db:open_doc_revs(Db, DocId, Revs, Options), - ok = send_header(Mod, 200, resp_json_header(Mod)), - ok = send_chunk(Mod, "["), - % We loop through the docs. The first time through the separator - % is whitespace, then a comma on subsequent iterations. - lists:foldl( - fun(Result, AccSeparator) -> - case Result of - {ok, Doc} -> - JsonDoc= couch_doc:to_json_obj(Doc, Options), - ok = send_chunk(Mod, AccSeparator ++ lists:flatten(cjson:encode({obj, [{ok, JsonDoc}]}))); - {{not_found, missing}, RevId} -> - Json = {obj, [{"missing", RevId}]}, - ok = send_chunk(Mod, AccSeparator ++ lists:flatten(cjson:encode(Json))) - end, - "," % AccSeparator now has a comma - end, - "", Results), - ok = send_chunk(Mod, "]"), - ok = send_final_chunk(Mod), - {ok, 200}. - -send_attachment(#mod{method=Method} = Mod, - #uri_parts{doc=DocId,attachment=Attachment}=Parts) -> - Db = open_db(Parts), - case couch_db:open_doc(Db, DocId, []) of - {ok, #doc{attachments=Attachments}} -> - case proplists:get_value(Attachment, Attachments) of - undefined -> - throw({not_found, missing}); - {Type, Bin} -> - ok = send_header(Mod, 200, resp_header(Mod, Type) ++ - [{"content-type", Type}, - {"content-length", integer_to_list(couch_doc:bin_size(Bin))}]), - case Method of - "GET" -> - couch_doc:bin_foldl(Bin, - fun(BinSegment, []) -> - ok = send_chunk(Mod, BinSegment), - {ok, []} - end, - []); - "HEAD" -> - ok - end, - ok = send_final_chunk(Mod), - {ok, 200} - end; - Error -> - throw(Error) - end. - - -send_json(Mod, Code, JsonData) -> - send_json(Mod, Code, JsonData, []). - -send_json(#mod{method=Method}=Mod, Code, JsonData, Headers) -> - case Method of - "HEAD" -> - ok = send_header(Mod, Code, resp_json_header(Mod, [no_body]) ++ Headers); - _ -> - ok = send_header(Mod, Code, resp_json_header(Mod) ++ Headers), - ok = send_chunk(Mod, lists:flatten([cjson:encode(JsonData) | "\n"])), - ok = send_final_chunk(Mod) - end, - {ok, Code}. - - -send_ok(Mod, Code) -> - send_ok(Mod, Code, []). - -send_ok(Mod, Code, AdditionalProps) -> - send_ok(Mod, Code, AdditionalProps, []). - -send_ok(Mod, Code, AdditionalProps, AdditionalHeaders) -> - send_json(Mod, Code, {obj, [{ok, true}|AdditionalProps]}, AdditionalHeaders). - - -make_view_fold_fun(Mod, QueryArgs) -> - #query_args{ - end_key=EndKey, - end_docid=EndDocId, - direction=Dir, - count=Count - } = QueryArgs, - - PassedEndFun = - case Dir of - fwd -> - fun(ViewKey, ViewId) -> - couch_view:less_json({EndKey,EndDocId}, {ViewKey,ViewId}) - end; - rev-> - fun(ViewKey, ViewId) -> - couch_view:less_json({ViewKey, ViewId}, {EndKey,EndDocId}) - end - end, - - NegCountFun = - fun(Id, Key, Value, Offset, TotalViewCount, {AccCount, AccSkip, HeaderSent, AccRevRows}) -> - PassedEnd = PassedEndFun(Key, Id), - case {PassedEnd, AccCount, AccSkip, HeaderSent} of - {true,_,_,_} -> - % The stop key has been passed, stop looping. - {stop, {AccCount, AccSkip, HeaderSent, AccRevRows}}; - {_,0,_,_} -> - {stop, {0, 0, HeaderSent, AccRevRows}}; % we've done "count" rows, stop foldling - {_,_,AccSkip,_} when AccSkip > 0 -> - {ok, {AccCount, AccSkip - 1, HeaderSent, AccRevRows}}; - {_,AccCount,_,header_sent} -> - JsonObj = {obj, [{"key",Key},{"id",Id},{"value",Value}]}, - {ok, {AccCount + 1, 0, header_sent, [cjson:encode(JsonObj), "," | AccRevRows]}}; - {_,_,_,header_not_sent} -> - ok = send_header(Mod, 200, resp_json_header(Mod)), - Offset2= TotalViewCount - Offset - - lists:min([TotalViewCount - Offset, - AccCount]), - JsonBegin = io_lib:format("{\"total_rows\":~w,\"offset\":~w,\"rows\":[", - [TotalViewCount, Offset2]), - JsonObj = {obj, [{"key",Key},{"id",Id},{"value",Value}]}, - ok = send_chunk(Mod, lists:flatten(JsonBegin)), - {ok, {AccCount + 1, 0, header_sent, [cjson:encode(JsonObj) | AccRevRows]}} - end - end, - - PosCountFun = - fun(Id, Key, Value, Offset, TotalViewCount, {AccCount, AccSkip, HeaderSent, AccRevRows}) -> - PassedEnd = PassedEndFun(Key, Id), - case {PassedEnd, AccCount, AccSkip, HeaderSent} of - {true,_,_,_} -> - % The stop key has been passed, stop looping. - {stop, {AccCount, AccSkip, HeaderSent, AccRevRows}}; - {_,0,_,_} -> - {stop, {0, 0, HeaderSent, AccRevRows}}; % we've done "count" rows, stop foldling - {_,_,AccSkip,_} when AccSkip > 0 -> - {ok, {AccCount, AccSkip - 1, HeaderSent, AccRevRows}}; - {_,AccCount,_,header_sent} when (AccCount > 0) -> - JsonObj = {obj, [{"key",Key},{"id",Id},{"value",Value}]}, - ok = send_chunk(Mod, "," ++ lists:flatten(cjson:encode(JsonObj))), - {ok, {AccCount - 1, 0, header_sent, AccRevRows}}; - {_,_,_,header_not_sent} -> - ok = send_header(Mod, 200, resp_json_header(Mod)), - JsonBegin = io_lib:format("{\"total_rows\":~w,\"offset\":~w,\"rows\":[", - [TotalViewCount, Offset]), - JsonObj = {obj, [{"key",Key},{"id",Id},{"value",Value}]}, - ok = send_chunk(Mod, lists:flatten(JsonBegin ++ cjson:encode(JsonObj))), - {ok, {AccCount - 1, 0, header_sent, AccRevRows}} - end - end, - case Count > 0 of - true -> PosCountFun; - false -> NegCountFun - end. - -finish_view_fold(Mod, FoldResult) -> - case FoldResult of - {ok, TotalRows, {_, _, header_not_sent, _}} -> - % nothing found in the view, nothing has been returned - % send empty view - ok = send_header(Mod, 200, resp_json_header(Mod)), - JsonEmptyView = lists:flatten( - io_lib:format("{\"total_rows\":~w,\"rows\":[]}\n", - [TotalRows])), - ok = send_chunk(Mod, JsonEmptyView), - ok = send_final_chunk(Mod), - {ok, 200}; - {ok, _TotalRows, {_, _, header_sent, AccRevRows}} -> - % end the view - ok = send_chunk(Mod, lists:flatten(AccRevRows) ++ "]}\n"), - ok = send_final_chunk(Mod), - {ok, 200}; - Error -> - throw(Error) - end. - - -send_temp_view(#mod{entity_body=Body,parsed_header=Headers}=Mod, - #uri_parts{db=DbName, querystr=QueryStr}) -> - #query_args{ - start_key=StartKey, - count=Count, - skip=SkipCount, - direction=Dir, - start_docid=StartDocId} = QueryArgs = view_parse_query(QueryStr), - Type0 = proplists:get_value("content-type", Headers, "text/javascript"), - % remove the charset ("...;charset=foo") if its there - {ok, [Type|_]} = regexp:split(Type0, ";"), - View = {temp, DbName, Type, Body}, - Start = {StartKey, StartDocId}, - FoldlFun = make_view_fold_fun(Mod, QueryArgs), - FoldAccInit = {Count, SkipCount, header_not_sent, []}, - FoldResult = couch_view:fold(View, Start, Dir, FoldlFun, FoldAccInit), - finish_view_fold(Mod, FoldResult). - - -send_view(Mod, #uri_parts{db=DbName, doc=DesignDocId, view=ViewId, querystr=QueryStr}) -> - #query_args{ - start_key=StartKey, - count=Count, - skip=SkipCount, - direction=Dir, - start_docid=StartDocId} = QueryArgs = view_parse_query(QueryStr), - View = {DbName, DesignDocId, ViewId}, - Start = {StartKey, StartDocId}, - FoldlFun = make_view_fold_fun(Mod, QueryArgs), - FoldAccInit = {Count, SkipCount, header_not_sent, []}, - Result = couch_view:fold(View, Start, Dir, FoldlFun, FoldAccInit), - finish_view_fold(Mod, Result). - - -send_all_docs(Mod, #uri_parts{querystr=QueryStr}=Parts) -> - Db = open_db(Parts), - #query_args{ - start_key=StartKey, - start_docid=StartDocId, - count=Count, - skip=SkipCount, - direction=Dir} = QueryArgs = view_parse_query(QueryStr), - {ok, Info} = couch_db:get_db_info(Db), - TotalRowCount = proplists:get_value(doc_count, Info), - - StartId = - if is_list(StartKey) -> StartKey; - true -> StartDocId - end, - - FoldlFun = make_view_fold_fun(Mod, QueryArgs), - AdapterFun = - fun(#full_doc_info{id=Id}=FullDocInfo, Offset, Acc) -> - case couch_doc:to_doc_info(FullDocInfo) of - #doc_info{deleted=false, rev=Rev} -> - FoldlFun(Id, Id, {obj, [{rev, Rev}]}, Offset, TotalRowCount, Acc); - #doc_info{deleted=true} -> - {ok, Acc} - end - end, - {ok, FoldResult} = couch_db:enum_docs(Db, StartId, Dir, AdapterFun, - {Count, SkipCount, header_not_sent, []}), - finish_view_fold(Mod, {ok, TotalRowCount, FoldResult}). - -send_all_docs_by_seq(Mod, #uri_parts{querystr=QueryStr}=Parts) -> - Db = open_db(Parts), - QueryArgs = view_parse_query(QueryStr), - #query_args{ - start_key=StartKey, - count=Count, - skip=SkipCount, - direction=Dir} = QueryArgs, - - {ok, Info} = couch_db:get_db_info(Db), - TotalRowCount = proplists:get_value(doc_count, Info), - - FoldlFun = make_view_fold_fun(Mod, QueryArgs), - - StartKey2 = - case StartKey of - nil -> 0; - <<>> -> 100000000000; - StartKey when is_integer(StartKey) -> StartKey - end, - {ok, FoldResult} = - couch_db:enum_docs_since(Db, StartKey2, Dir, - fun(DocInfo, Offset, Acc) -> - #doc_info{ - id=Id, - rev=Rev, - update_seq=UpdateSeq, - deleted=Deleted, - conflict_revs=ConflictRevs, - deleted_conflict_revs=DelConflictRevs} = DocInfo, - Json = - {obj, - [{"rev", Rev}] ++ - case ConflictRevs of - [] -> []; - _ -> [{"conflicts", list_to_tuple(ConflictRevs)}] - end ++ - case DelConflictRevs of - [] -> []; - _ -> [{"deleted_conflicts", list_to_tuple(DelConflictRevs)}] - end ++ - case Deleted of - true -> [{"deleted", true}]; - false -> [] - end - }, - FoldlFun(Id, UpdateSeq, Json, Offset, TotalRowCount, Acc) - end, {Count, SkipCount, header_not_sent, []}), - finish_view_fold(Mod, {ok, TotalRowCount, FoldResult}). - - - -send_all_dbs(Mod, _Parts)-> - {ok, DbNames} = couch_server:all_databases(), - ok = send_header(Mod, 200, resp_json_header(Mod)), - ok = send_chunk(Mod, lists:flatten(cjson:encode(list_to_tuple(DbNames)))), - ok = send_final_chunk(Mod), - {ok, 200}. - -send_error(Mod, Error) -> - {Json, Code} = error_to_json(Error), - couch_log:info("HTTP Error (code ~w): ~p", [Code, Json]), - send_json(Mod, Code, Json). - - - -% convert an error response into a json object and http error code. -error_to_json(Error) -> - {HttpCode, Atom, Reason} = error_to_json0(Error), - Reason1 = - case (catch io_lib:format("~s", [Reason])) of - Reason0 when is_list(Reason0) -> - lists:flatten(Reason0); - _ -> - lists:flatten(io_lib:format("~p", [Reason])) % else term to text - end, - Json = - {obj, - [{error, atom_to_list(Atom)}, - {reason, Reason1}]}, - {Json, HttpCode}. - -error_to_json0(not_found) -> - {404, not_found, "missing"}; -error_to_json0({missing_rev, Msg}) -> - {412, missing_rev, Msg}; -error_to_json0({not_found, Reason}) -> - {404, not_found, Reason}; -error_to_json0({database_already_exists, Reason}) -> - {409, database_already_exists, Reason}; -error_to_json0(conflict) -> - {412, conflict, "Update conflict"}; -error_to_json0({doc_validation, Msg}) -> - {406, doc_validation, Msg}; -error_to_json0({Id, Reason}) when is_atom(Id) -> - {500, Id, Reason}; -error_to_json0(Error) -> - {500, error, Error}. - -%% -%% Configuration -%% - -%% load - -load("Foo Bar", []) -> - {ok, [], {script_alias, {"foo", "bar"}}}. diff --git a/src/mochiweb/Makefile.am b/src/mochiweb/Makefile.am new file mode 100644 index 00000000..cbd1438a --- /dev/null +++ b/src/mochiweb/Makefile.am @@ -0,0 +1,75 @@ +## Licensed under the Apache License, Version 2.0 (the "License"); you may not +## use this file except in compliance with the License. You may obtain a copy +## of the License at +## +## http://www.apache.org/licenses/LICENSE-2.0 +## +## Unless required by applicable law or agreed to in writing, software +## distributed under the License is distributed on an "AS IS" BASIS, WITHOUT +## WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the +## License for the specific language governing permissions and limitations under +## the License. + +datarootdir = @prefix@/share + +mochiwebebindir = $(erlanglibdir)/mochiweb-r64/ebin + +mochiweb_file_collection = \ + mochihex.erl \ + mochijson.erl \ + mochijson2.erl \ + mochinum.erl \ + mochiweb.erl \ + mochiweb_app.erl \ + mochiweb_charref.erl \ + mochiweb_cookies.erl \ + mochiweb_echo.erl \ + mochiweb_headers.erl \ + mochiweb_html.erl \ + mochiweb_http.erl \ + mochiweb_multipart.erl \ + mochiweb_request.erl \ + mochiweb_response.erl \ + mochiweb_skel.erl \ + mochiweb_socket_server.erl \ + mochiweb_sup.erl \ + mochiweb_util.erl \ + reloader.erl + +mochiwebebin_static_file = mochiweb.app + +mochiwebebin_make_generated_file_list = \ + mochihex.beam \ + mochijson.beam \ + mochijson2.beam \ + mochinum.beam \ + mochiweb.beam \ + mochiweb_app.beam \ + mochiweb_charref.beam \ + mochiweb_cookies.beam \ + mochiweb_echo.beam \ + mochiweb_headers.beam \ + mochiweb_html.beam \ + mochiweb_http.beam \ + mochiweb_multipart.beam \ + mochiweb_request.beam \ + mochiweb_response.beam \ + mochiweb_skel.beam \ + mochiweb_socket_server.beam \ + mochiweb_sup.beam \ + mochiweb_util.beam \ + reloader.beam + +mochiwebebin_DATA = \ + $(mochiwebebin_static_file) \ + $(mochiwebebin_make_generated_file_list) + +EXTRA_DIST = \ + $(mochiweb_file_collection) \ + $(mochiwebebin_static_file) + +CLEANFILES = \ + $(mochiwebebin_make_generated_file_list) + +%.beam: %.erl + erlc $< diff --git a/src/mochiweb/mochihex.erl b/src/mochiweb/mochihex.erl new file mode 100644 index 00000000..7fe6899e --- /dev/null +++ b/src/mochiweb/mochihex.erl @@ -0,0 +1,75 @@ +%% @author Bob Ippolito <bob@mochimedia.com> +%% @copyright 2006 Mochi Media, Inc. + +%% @doc Utilities for working with hexadecimal strings. + +-module(mochihex). +-author('bob@mochimedia.com'). + +-export([test/0, to_hex/1, to_bin/1, to_int/1, dehex/1, hexdigit/1]). + +%% @type iolist() = [char() | binary() | iolist()] +%% @type iodata() = iolist() | binary() + +%% @spec to_hex(integer | iolist()) -> string() +%% @doc Convert an iolist to a hexadecimal string. +to_hex(0) -> + "0"; +to_hex(I) when is_integer(I), I > 0 -> + to_hex_int(I, []); +to_hex(B) -> + to_hex(iolist_to_binary(B), []). + +%% @spec to_bin(string()) -> binary() +%% @doc Convert a hexadecimal string to a binary. +to_bin(L) -> + to_bin(L, []). + +%% @spec to_int(string()) -> integer() +%% @doc Convert a hexadecimal string to an integer. +to_int(L) -> + erlang:list_to_integer(L, 16). + +%% @spec dehex(char()) -> integer() +%% @doc Convert a hex digit to its integer value. +dehex(C) when C >= $0, C =< $9 -> + C - $0; +dehex(C) when C >= $a, C =< $f -> + C - $a + 10; +dehex(C) when C >= $A, C =< $F -> + C - $A + 10. + +%% @spec hexdigit(integer()) -> char() +%% @doc Convert an integer less than 16 to a hex digit. +hexdigit(C) when C >= 0, C =< 9 -> + C + $0; +hexdigit(C) when C =< 15 -> + C + $a - 10. + +%% @spec test() -> ok +%% @doc Test this module. +test() -> + "ff000ff1" = to_hex([255, 0, 15, 241]), + <<255, 0, 15, 241>> = to_bin("ff000ff1"), + 16#ff000ff1 = to_int("ff000ff1"), + "ff000ff1" = to_hex(16#ff000ff1), + ok. + + +%% Internal API + +to_hex(<<>>, Acc) -> + lists:reverse(Acc); +to_hex(<<C1:4, C2:4, Rest/binary>>, Acc) -> + to_hex(Rest, [hexdigit(C2), hexdigit(C1) | Acc]). + +to_hex_int(0, Acc) -> + Acc; +to_hex_int(I, Acc) -> + to_hex_int(I bsr 4, [hexdigit(I band 15) | Acc]). + +to_bin([], Acc) -> + iolist_to_binary(lists:reverse(Acc)); +to_bin([C1, C2 | Rest], Acc) -> + to_bin(Rest, [(dehex(C1) bsl 4) bor dehex(C2) | Acc]). + diff --git a/src/mochiweb/mochijson.erl b/src/mochiweb/mochijson.erl new file mode 100644 index 00000000..6ea7ec56 --- /dev/null +++ b/src/mochiweb/mochijson.erl @@ -0,0 +1,529 @@ +%% @author Bob Ippolito <bob@mochimedia.com> +%% @copyright 2006 Mochi Media, Inc. + +%% @doc Yet another JSON (RFC 4627) library for Erlang. +-module(mochijson). +-author('bob@mochimedia.com'). +-export([encoder/1, encode/1]). +-export([decoder/1, decode/1]). +-export([binary_encoder/1, binary_encode/1]). +-export([binary_decoder/1, binary_decode/1]). +-export([test/0]). + +% This is a macro to placate syntax highlighters.. +-define(Q, $\"). +-define(ADV_COL(S, N), S#decoder{column=N+S#decoder.column}). +-define(INC_COL(S), S#decoder{column=1+S#decoder.column}). +-define(INC_LINE(S), S#decoder{column=1, line=1+S#decoder.line}). + +%% @type iolist() = [char() | binary() | iolist()] +%% @type iodata() = iolist() | binary() +%% @type json_string() = atom | string() | binary() +%% @type json_number() = integer() | float() +%% @type json_array() = {array, [json_term()]} +%% @type json_object() = {struct, [{json_string(), json_term()}]} +%% @type json_term() = json_string() | json_number() | json_array() | +%% json_object() +%% @type encoding() = utf8 | unicode +%% @type encoder_option() = {input_encoding, encoding()} | +%% {handler, function()} +%% @type decoder_option() = {input_encoding, encoding()} | +%% {object_hook, function()} +%% @type bjson_string() = binary() +%% @type bjson_number() = integer() | float() +%% @type bjson_array() = [bjson_term()] +%% @type bjson_object() = {struct, [{bjson_string(), bjson_term()}]} +%% @type bjson_term() = bjson_string() | bjson_number() | bjson_array() | +%% bjson_object() +%% @type binary_encoder_option() = {handler, function()} +%% @type binary_decoder_option() = {object_hook, function()} + +-record(encoder, {input_encoding=unicode, + handler=null}). + +-record(decoder, {input_encoding=utf8, + object_hook=null, + line=1, + column=1, + state=null}). + +%% @spec encoder([encoder_option()]) -> function() +%% @doc Create an encoder/1 with the given options. +encoder(Options) -> + State = parse_encoder_options(Options, #encoder{}), + fun (O) -> json_encode(O, State) end. + +%% @spec encode(json_term()) -> iolist() +%% @doc Encode the given as JSON to an iolist. +encode(Any) -> + json_encode(Any, #encoder{}). + +%% @spec decoder([decoder_option()]) -> function() +%% @doc Create a decoder/1 with the given options. +decoder(Options) -> + State = parse_decoder_options(Options, #decoder{}), + fun (O) -> json_decode(O, State) end. + +%% @spec decode(iolist()) -> json_term() +%% @doc Decode the given iolist to Erlang terms. +decode(S) -> + json_decode(S, #decoder{}). + +%% @spec binary_decoder([binary_decoder_option()]) -> function() +%% @doc Create a binary_decoder/1 with the given options. +binary_decoder(Options) -> + mochijson2:decoder(Options). + +%% @spec binary_encoder([binary_encoder_option()]) -> function() +%% @doc Create a binary_encoder/1 with the given options. +binary_encoder(Options) -> + mochijson2:encoder(Options). + +%% @spec binary_encode(bjson_term()) -> iolist() +%% @doc Encode the given as JSON to an iolist, using lists for arrays and +%% binaries for strings. +binary_encode(Any) -> + mochijson2:encode(Any). + +%% @spec binary_decode(iolist()) -> bjson_term() +%% @doc Decode the given iolist to Erlang terms, using lists for arrays and +%% binaries for strings. +binary_decode(S) -> + mochijson2:decode(S). + +test() -> + test_all(), + mochijson2:test(). + +%% Internal API + +parse_encoder_options([], State) -> + State; +parse_encoder_options([{input_encoding, Encoding} | Rest], State) -> + parse_encoder_options(Rest, State#encoder{input_encoding=Encoding}); +parse_encoder_options([{handler, Handler} | Rest], State) -> + parse_encoder_options(Rest, State#encoder{handler=Handler}). + +parse_decoder_options([], State) -> + State; +parse_decoder_options([{input_encoding, Encoding} | Rest], State) -> + parse_decoder_options(Rest, State#decoder{input_encoding=Encoding}); +parse_decoder_options([{object_hook, Hook} | Rest], State) -> + parse_decoder_options(Rest, State#decoder{object_hook=Hook}). + +json_encode(true, _State) -> + "true"; +json_encode(false, _State) -> + "false"; +json_encode(null, _State) -> + "null"; +json_encode(I, _State) when is_integer(I) -> + integer_to_list(I); +json_encode(F, _State) when is_float(F) -> + mochinum:digits(F); +json_encode(L, State) when is_list(L); is_binary(L); is_atom(L) -> + json_encode_string(L, State); +json_encode({array, Props}, State) when is_list(Props) -> + json_encode_array(Props, State); +json_encode({struct, Props}, State) when is_list(Props) -> + json_encode_proplist(Props, State); +json_encode(Bad, #encoder{handler=null}) -> + exit({json_encode, {bad_term, Bad}}); +json_encode(Bad, State=#encoder{handler=Handler}) -> + json_encode(Handler(Bad), State). + +json_encode_array([], _State) -> + "[]"; +json_encode_array(L, State) -> + F = fun (O, Acc) -> + [$,, json_encode(O, State) | Acc] + end, + [$, | Acc1] = lists:foldl(F, "[", L), + lists:reverse([$\] | Acc1]). + +json_encode_proplist([], _State) -> + "{}"; +json_encode_proplist(Props, State) -> + F = fun ({K, V}, Acc) -> + KS = case K of + K when is_atom(K) -> + json_encode_string_utf8(atom_to_list(K)); + K when is_integer(K) -> + json_encode_string(integer_to_list(K), State); + K when is_list(K); is_binary(K) -> + json_encode_string(K, State) + end, + VS = json_encode(V, State), + [$,, VS, $:, KS | Acc] + end, + [$, | Acc1] = lists:foldl(F, "{", Props), + lists:reverse([$\} | Acc1]). + +json_encode_string(A, _State) when is_atom(A) -> + json_encode_string_unicode(xmerl_ucs:from_utf8(atom_to_list(A))); +json_encode_string(B, _State) when is_binary(B) -> + json_encode_string_unicode(xmerl_ucs:from_utf8(B)); +json_encode_string(S, #encoder{input_encoding=utf8}) -> + json_encode_string_utf8(S); +json_encode_string(S, #encoder{input_encoding=unicode}) -> + json_encode_string_unicode(S). + +json_encode_string_utf8(S) -> + [?Q | json_encode_string_utf8_1(S)]. + +json_encode_string_utf8_1([C | Cs]) when C >= 0, C =< 16#7f -> + NewC = case C of + $\\ -> "\\\\"; + ?Q -> "\\\""; + _ when C >= $\s, C < 16#7f -> C; + $\t -> "\\t"; + $\n -> "\\n"; + $\r -> "\\r"; + $\f -> "\\f"; + $\b -> "\\b"; + _ when C >= 0, C =< 16#7f -> unihex(C); + _ -> exit({json_encode, {bad_char, C}}) + end, + [NewC | json_encode_string_utf8_1(Cs)]; +json_encode_string_utf8_1(All=[C | _]) when C >= 16#80, C =< 16#10FFFF -> + json_encode_string_unicode(xmerl_ucs:from_utf8(All)); +json_encode_string_utf8_1([]) -> + "\"". + +json_encode_string_unicode(S) -> + [?Q | json_encode_string_unicode_1(S)]. + +json_encode_string_unicode_1([C | Cs]) -> + NewC = case C of + $\\ -> "\\\\"; + ?Q -> "\\\""; + _ when C >= $\s, C < 16#7f -> C; + $\t -> "\\t"; + $\n -> "\\n"; + $\r -> "\\r"; + $\f -> "\\f"; + $\b -> "\\b"; + _ when C >= 0, C =< 16#10FFFF -> unihex(C); + _ -> exit({json_encode, {bad_char, C}}) + end, + [NewC | json_encode_string_unicode_1(Cs)]; +json_encode_string_unicode_1([]) -> + "\"". + +dehex(C) when C >= $0, C =< $9 -> + C - $0; +dehex(C) when C >= $a, C =< $f -> + C - $a + 10; +dehex(C) when C >= $A, C =< $F -> + C - $A + 10. + +hexdigit(C) when C >= 0, C =< 9 -> + C + $0; +hexdigit(C) when C =< 15 -> + C + $a - 10. + +unihex(C) when C < 16#10000 -> + <<D3:4, D2:4, D1:4, D0:4>> = <<C:16>>, + Digits = [hexdigit(D) || D <- [D3, D2, D1, D0]], + [$\\, $u | Digits]; +unihex(C) when C =< 16#10FFFF -> + N = C - 16#10000, + S1 = 16#d800 bor ((N bsr 10) band 16#3ff), + S2 = 16#dc00 bor (N band 16#3ff), + [unihex(S1), unihex(S2)]. + +json_decode(B, S) when is_binary(B) -> + json_decode(binary_to_list(B), S); +json_decode(L, S) -> + {Res, L1, S1} = decode1(L, S), + {eof, [], _} = tokenize(L1, S1#decoder{state=trim}), + Res. + +decode1(L, S=#decoder{state=null}) -> + case tokenize(L, S#decoder{state=any}) of + {{const, C}, L1, S1} -> + {C, L1, S1}; + {start_array, L1, S1} -> + decode_array(L1, S1#decoder{state=any}, []); + {start_object, L1, S1} -> + decode_object(L1, S1#decoder{state=key}, []) + end. + +make_object(V, #decoder{object_hook=null}) -> + V; +make_object(V, #decoder{object_hook=Hook}) -> + Hook(V). + +decode_object(L, S=#decoder{state=key}, Acc) -> + case tokenize(L, S) of + {end_object, Rest, S1} -> + V = make_object({struct, lists:reverse(Acc)}, S1), + {V, Rest, S1#decoder{state=null}}; + {{const, K}, Rest, S1} when is_list(K) -> + {colon, L2, S2} = tokenize(Rest, S1), + {V, L3, S3} = decode1(L2, S2#decoder{state=null}), + decode_object(L3, S3#decoder{state=comma}, [{K, V} | Acc]) + end; +decode_object(L, S=#decoder{state=comma}, Acc) -> + case tokenize(L, S) of + {end_object, Rest, S1} -> + V = make_object({struct, lists:reverse(Acc)}, S1), + {V, Rest, S1#decoder{state=null}}; + {comma, Rest, S1} -> + decode_object(Rest, S1#decoder{state=key}, Acc) + end. + +decode_array(L, S=#decoder{state=any}, Acc) -> + case tokenize(L, S) of + {end_array, Rest, S1} -> + {{array, lists:reverse(Acc)}, Rest, S1#decoder{state=null}}; + {start_array, Rest, S1} -> + {Array, Rest1, S2} = decode_array(Rest, S1#decoder{state=any}, []), + decode_array(Rest1, S2#decoder{state=comma}, [Array | Acc]); + {start_object, Rest, S1} -> + {Array, Rest1, S2} = decode_object(Rest, S1#decoder{state=key}, []), + decode_array(Rest1, S2#decoder{state=comma}, [Array | Acc]); + {{const, Const}, Rest, S1} -> + decode_array(Rest, S1#decoder{state=comma}, [Const | Acc]) + end; +decode_array(L, S=#decoder{state=comma}, Acc) -> + case tokenize(L, S) of + {end_array, Rest, S1} -> + {{array, lists:reverse(Acc)}, Rest, S1#decoder{state=null}}; + {comma, Rest, S1} -> + decode_array(Rest, S1#decoder{state=any}, Acc) + end. + +tokenize_string(IoList=[C | _], S=#decoder{input_encoding=utf8}, Acc) + when is_list(C); is_binary(C); C >= 16#7f -> + List = xmerl_ucs:from_utf8(iolist_to_binary(IoList)), + tokenize_string(List, S#decoder{input_encoding=unicode}, Acc); +tokenize_string("\"" ++ Rest, S, Acc) -> + {lists:reverse(Acc), Rest, ?INC_COL(S)}; +tokenize_string("\\\"" ++ Rest, S, Acc) -> + tokenize_string(Rest, ?ADV_COL(S, 2), [$\" | Acc]); +tokenize_string("\\\\" ++ Rest, S, Acc) -> + tokenize_string(Rest, ?ADV_COL(S, 2), [$\\ | Acc]); +tokenize_string("\\/" ++ Rest, S, Acc) -> + tokenize_string(Rest, ?ADV_COL(S, 2), [$/ | Acc]); +tokenize_string("\\b" ++ Rest, S, Acc) -> + tokenize_string(Rest, ?ADV_COL(S, 2), [$\b | Acc]); +tokenize_string("\\f" ++ Rest, S, Acc) -> + tokenize_string(Rest, ?ADV_COL(S, 2), [$\f | Acc]); +tokenize_string("\\n" ++ Rest, S, Acc) -> + tokenize_string(Rest, ?ADV_COL(S, 2), [$\n | Acc]); +tokenize_string("\\r" ++ Rest, S, Acc) -> + tokenize_string(Rest, ?ADV_COL(S, 2), [$\r | Acc]); +tokenize_string("\\t" ++ Rest, S, Acc) -> + tokenize_string(Rest, ?ADV_COL(S, 2), [$\t | Acc]); +tokenize_string([$\\, $u, C3, C2, C1, C0 | Rest], S, Acc) -> + % coalesce UTF-16 surrogate pair? + C = dehex(C0) bor + (dehex(C1) bsl 4) bor + (dehex(C2) bsl 8) bor + (dehex(C3) bsl 12), + tokenize_string(Rest, ?ADV_COL(S, 6), [C | Acc]); +tokenize_string([C | Rest], S, Acc) when C >= $\s; C < 16#10FFFF -> + tokenize_string(Rest, ?ADV_COL(S, 1), [C | Acc]). + +tokenize_number(IoList=[C | _], Mode, S=#decoder{input_encoding=utf8}, Acc) + when is_list(C); is_binary(C); C >= 16#7f -> + List = xmerl_ucs:from_utf8(iolist_to_binary(IoList)), + tokenize_number(List, Mode, S#decoder{input_encoding=unicode}, Acc); +tokenize_number([$- | Rest], sign, S, []) -> + tokenize_number(Rest, int, ?INC_COL(S), [$-]); +tokenize_number(Rest, sign, S, []) -> + tokenize_number(Rest, int, S, []); +tokenize_number([$0 | Rest], int, S, Acc) -> + tokenize_number(Rest, frac, ?INC_COL(S), [$0 | Acc]); +tokenize_number([C | Rest], int, S, Acc) when C >= $1, C =< $9 -> + tokenize_number(Rest, int1, ?INC_COL(S), [C | Acc]); +tokenize_number([C | Rest], int1, S, Acc) when C >= $0, C =< $9 -> + tokenize_number(Rest, int1, ?INC_COL(S), [C | Acc]); +tokenize_number(Rest, int1, S, Acc) -> + tokenize_number(Rest, frac, S, Acc); +tokenize_number([$., C | Rest], frac, S, Acc) when C >= $0, C =< $9 -> + tokenize_number(Rest, frac1, ?ADV_COL(S, 2), [C, $. | Acc]); +tokenize_number([E | Rest], frac, S, Acc) when E == $e; E == $E -> + tokenize_number(Rest, esign, ?INC_COL(S), [$e, $0, $. | Acc]); +tokenize_number(Rest, frac, S, Acc) -> + {{int, lists:reverse(Acc)}, Rest, S}; +tokenize_number([C | Rest], frac1, S, Acc) when C >= $0, C =< $9 -> + tokenize_number(Rest, frac1, ?INC_COL(S), [C | Acc]); +tokenize_number([E | Rest], frac1, S, Acc) when E == $e; E == $E -> + tokenize_number(Rest, esign, ?INC_COL(S), [$e | Acc]); +tokenize_number(Rest, frac1, S, Acc) -> + {{float, lists:reverse(Acc)}, Rest, S}; +tokenize_number([C | Rest], esign, S, Acc) when C == $-; C == $+ -> + tokenize_number(Rest, eint, ?INC_COL(S), [C | Acc]); +tokenize_number(Rest, esign, S, Acc) -> + tokenize_number(Rest, eint, S, Acc); +tokenize_number([C | Rest], eint, S, Acc) when C >= $0, C =< $9 -> + tokenize_number(Rest, eint1, ?INC_COL(S), [C | Acc]); +tokenize_number([C | Rest], eint1, S, Acc) when C >= $0, C =< $9 -> + tokenize_number(Rest, eint1, ?INC_COL(S), [C | Acc]); +tokenize_number(Rest, eint1, S, Acc) -> + {{float, lists:reverse(Acc)}, Rest, S}. + +tokenize([], S=#decoder{state=trim}) -> + {eof, [], S}; +tokenize([L | Rest], S) when is_list(L) -> + tokenize(L ++ Rest, S); +tokenize([B | Rest], S) when is_binary(B) -> + tokenize(xmerl_ucs:from_utf8(B) ++ Rest, S); +tokenize("\r\n" ++ Rest, S) -> + tokenize(Rest, ?INC_LINE(S)); +tokenize("\n" ++ Rest, S) -> + tokenize(Rest, ?INC_LINE(S)); +tokenize([C | Rest], S) when C == $\s; C == $\t -> + tokenize(Rest, ?INC_COL(S)); +tokenize("{" ++ Rest, S) -> + {start_object, Rest, ?INC_COL(S)}; +tokenize("}" ++ Rest, S) -> + {end_object, Rest, ?INC_COL(S)}; +tokenize("[" ++ Rest, S) -> + {start_array, Rest, ?INC_COL(S)}; +tokenize("]" ++ Rest, S) -> + {end_array, Rest, ?INC_COL(S)}; +tokenize("," ++ Rest, S) -> + {comma, Rest, ?INC_COL(S)}; +tokenize(":" ++ Rest, S) -> + {colon, Rest, ?INC_COL(S)}; +tokenize("null" ++ Rest, S) -> + {{const, null}, Rest, ?ADV_COL(S, 4)}; +tokenize("true" ++ Rest, S) -> + {{const, true}, Rest, ?ADV_COL(S, 4)}; +tokenize("false" ++ Rest, S) -> + {{const, false}, Rest, ?ADV_COL(S, 5)}; +tokenize("\"" ++ Rest, S) -> + {String, Rest1, S1} = tokenize_string(Rest, ?INC_COL(S), []), + {{const, String}, Rest1, S1}; +tokenize(L=[C | _], S) when C >= $0, C =< $9; C == $- -> + case tokenize_number(L, sign, S, []) of + {{int, Int}, Rest, S1} -> + {{const, list_to_integer(Int)}, Rest, S1}; + {{float, Float}, Rest, S1} -> + {{const, list_to_float(Float)}, Rest, S1} + end. + +%% testing constructs borrowed from the Yaws JSON implementation. + +%% Create an object from a list of Key/Value pairs. + +obj_new() -> + {struct, []}. + +is_obj({struct, Props}) -> + F = fun ({K, _}) when is_list(K) -> + true; + (_) -> + false + end, + lists:all(F, Props). + +obj_from_list(Props) -> + Obj = {struct, Props}, + case is_obj(Obj) of + true -> Obj; + false -> exit(json_bad_object) + end. + +%% Test for equivalence of Erlang terms. +%% Due to arbitrary order of construction, equivalent objects might +%% compare unequal as erlang terms, so we need to carefully recurse +%% through aggregates (tuples and objects). + +equiv({struct, Props1}, {struct, Props2}) -> + equiv_object(Props1, Props2); +equiv({array, L1}, {array, L2}) -> + equiv_list(L1, L2); +equiv(N1, N2) when is_number(N1), is_number(N2) -> N1 == N2; +equiv(S1, S2) when is_list(S1), is_list(S2) -> S1 == S2; +equiv(true, true) -> true; +equiv(false, false) -> true; +equiv(null, null) -> true. + +%% Object representation and traversal order is unknown. +%% Use the sledgehammer and sort property lists. + +equiv_object(Props1, Props2) -> + L1 = lists:keysort(1, Props1), + L2 = lists:keysort(1, Props2), + Pairs = lists:zip(L1, L2), + true = lists:all(fun({{K1, V1}, {K2, V2}}) -> + equiv(K1, K2) and equiv(V1, V2) + end, Pairs). + +%% Recursively compare tuple elements for equivalence. + +equiv_list([], []) -> + true; +equiv_list([V1 | L1], [V2 | L2]) -> + case equiv(V1, V2) of + true -> + equiv_list(L1, L2); + false -> + false + end. + +test_all() -> + test_one(e2j_test_vec(utf8), 1). + +test_one([], _N) -> + %% io:format("~p tests passed~n", [N-1]), + ok; +test_one([{E, J} | Rest], N) -> + %% io:format("[~p] ~p ~p~n", [N, E, J]), + true = equiv(E, decode(J)), + true = equiv(E, decode(encode(E))), + test_one(Rest, 1+N). + +e2j_test_vec(unicode) -> + [ + {"foo" ++ [500] ++ "bar", [$", $f, $o, $o, 500, $b, $a, $r, $"]} + ]; +e2j_test_vec(utf8) -> + [ + {1, "1"}, + {3.1416, "3.14160"}, % text representation may truncate, trail zeroes + {-1, "-1"}, + {-3.1416, "-3.14160"}, + {12.0e10, "1.20000e+11"}, + {1.234E+10, "1.23400e+10"}, + {-1.234E-10, "-1.23400e-10"}, + {10.0, "1.0e+01"}, + {123.456, "1.23456E+2"}, + {10.0, "1e1"}, + {"foo", "\"foo\""}, + {"foo" ++ [5] ++ "bar", "\"foo\\u0005bar\""}, + {"", "\"\""}, + {"\"", "\"\\\"\""}, + {"\n\n\n", "\"\\n\\n\\n\""}, + {"\\", "\"\\\\\""}, + {"\" \b\f\r\n\t\"", "\"\\\" \\b\\f\\r\\n\\t\\\"\""}, + {obj_new(), "{}"}, + {obj_from_list([{"foo", "bar"}]), "{\"foo\":\"bar\"}"}, + {obj_from_list([{"foo", "bar"}, {"baz", 123}]), + "{\"foo\":\"bar\",\"baz\":123}"}, + {{array, []}, "[]"}, + {{array, [{array, []}]}, "[[]]"}, + {{array, [1, "foo"]}, "[1,\"foo\"]"}, + + % json array in a json object + {obj_from_list([{"foo", {array, [123]}}]), + "{\"foo\":[123]}"}, + + % json object in a json object + {obj_from_list([{"foo", obj_from_list([{"bar", true}])}]), + "{\"foo\":{\"bar\":true}}"}, + + % fold evaluation order + {obj_from_list([{"foo", {array, []}}, + {"bar", obj_from_list([{"baz", true}])}, + {"alice", "bob"}]), + "{\"foo\":[],\"bar\":{\"baz\":true},\"alice\":\"bob\"}"}, + + % json object in a json array + {{array, [-123, "foo", obj_from_list([{"bar", {array, []}}]), null]}, + "[-123,\"foo\",{\"bar\":[]},null]"} + ]. diff --git a/src/mochiweb/mochijson2.erl b/src/mochiweb/mochijson2.erl new file mode 100644 index 00000000..dfaffbab --- /dev/null +++ b/src/mochiweb/mochijson2.erl @@ -0,0 +1,509 @@ +%% @author Bob Ippolito <bob@mochimedia.com> +%% @copyright 2007 Mochi Media, Inc. + +%% @doc Yet another JSON (RFC 4627) library for Erlang. mochijson2 works +%% with binaries as strings, arrays as lists (without an {array, _}) +%% wrapper and it only knows how to decode UTF-8 (and ASCII). + +-module(mochijson2). +-author('bob@mochimedia.com'). +-export([encoder/1, encode/1]). +-export([decoder/1, decode/1]). +-export([test/0]). + +% This is a macro to placate syntax highlighters.. +-define(Q, $\"). +-define(ADV_COL(S, N), S#decoder{offset=N+S#decoder.offset, + column=N+S#decoder.column}). +-define(INC_COL(S), S#decoder{offset=1+S#decoder.offset, + column=1+S#decoder.column}). +-define(INC_LINE(S), S#decoder{offset=1+S#decoder.offset, + column=1, + line=1+S#decoder.line}). +-define(INC_CHAR(S, C), + case C of + $\n -> + S#decoder{column=1, + line=1+S#decoder.line, + offset=1+S#decoder.offset}; + _ -> + S#decoder{column=1+S#decoder.column, + offset=1+S#decoder.offset} + end). +-define(IS_WHITESPACE(C), + (C =:= $\s orelse C =:= $\t orelse C =:= $\r orelse C =:= $\n)). + +%% @type iolist() = [char() | binary() | iolist()] +%% @type iodata() = iolist() | binary() +%% @type json_string() = atom | binary() +%% @type json_number() = integer() | float() +%% @type json_array() = [json_term()] +%% @type json_object() = {struct, [{json_string(), json_term()}]} +%% @type json_term() = json_string() | json_number() | json_array() | +%% json_object() + +-record(encoder, {handler=null}). + +-record(decoder, {object_hook=null, + offset=0, + line=1, + column=1, + state=null}). + +%% @spec encoder([encoder_option()]) -> function() +%% @doc Create an encoder/1 with the given options. +encoder(Options) -> + State = parse_encoder_options(Options, #encoder{}), + fun (O) -> json_encode(O, State) end. + +%% @spec encode(json_term()) -> iolist() +%% @doc Encode the given as JSON to an iolist. +encode(Any) -> + json_encode(Any, #encoder{}). + +%% @spec decoder([decoder_option()]) -> function() +%% @doc Create a decoder/1 with the given options. +decoder(Options) -> + State = parse_decoder_options(Options, #decoder{}), + fun (O) -> json_decode(O, State) end. + +%% @spec decode(iolist()) -> json_term() +%% @doc Decode the given iolist to Erlang terms. +decode(S) -> + json_decode(S, #decoder{}). + +test() -> + test_all(). + +%% Internal API + +parse_encoder_options([], State) -> + State; +parse_encoder_options([{handler, Handler} | Rest], State) -> + parse_encoder_options(Rest, State#encoder{handler=Handler}). + +parse_decoder_options([], State) -> + State; +parse_decoder_options([{object_hook, Hook} | Rest], State) -> + parse_decoder_options(Rest, State#decoder{object_hook=Hook}). + +json_encode(true, _State) -> + <<"true">>; +json_encode(false, _State) -> + <<"false">>; +json_encode(null, _State) -> + <<"null">>; +json_encode(I, _State) when is_integer(I) andalso I >= -2147483648 andalso I =< 2147483647 -> + %% Anything outside of 32-bit integers should be encoded as a float + integer_to_list(I); +json_encode(I, _State) when is_integer(I) -> + mochinum:digits(float(I)); +json_encode(F, _State) when is_float(F) -> + mochinum:digits(F); +json_encode(S, State) when is_binary(S); is_atom(S) -> + json_encode_string(S, State); +json_encode(Array, State) when is_list(Array) -> + json_encode_array(Array, State); +json_encode({struct, Props}, State) when is_list(Props) -> + json_encode_proplist(Props, State); +json_encode(Bad, #encoder{handler=null}) -> + exit({json_encode, {bad_term, Bad}}); +json_encode(Bad, State=#encoder{handler=Handler}) -> + json_encode(Handler(Bad), State). + +json_encode_array([], _State) -> + <<"[]">>; +json_encode_array(L, State) -> + F = fun (O, Acc) -> + [$,, json_encode(O, State) | Acc] + end, + [$, | Acc1] = lists:foldl(F, "[", L), + lists:reverse([$\] | Acc1]). + +json_encode_proplist([], _State) -> + <<"{}">>; +json_encode_proplist(Props, State) -> + F = fun ({K, V}, Acc) -> + KS = json_encode_string(K, State), + VS = json_encode(V, State), + [$,, VS, $:, KS | Acc] + end, + [$, | Acc1] = lists:foldl(F, "{", Props), + lists:reverse([$\} | Acc1]). + +json_encode_string(A, _State) when is_atom(A) -> + json_encode_string_unicode(xmerl_ucs:from_utf8(atom_to_list(A)), [?Q]); +json_encode_string(B, _State) when is_binary(B) -> + json_encode_string_unicode(xmerl_ucs:from_utf8(B), [?Q]); +json_encode_string(I, _State) when is_integer(I) -> + json_encode_string_unicode(integer_to_list(I), [?Q]); +json_encode_string(L, _State) when is_list(L) -> + json_encode_string_unicode(L, [?Q]). + +json_encode_string_unicode([], Acc) -> + lists:reverse([$\" | Acc]); +json_encode_string_unicode([C | Cs], Acc) -> + Acc1 = case C of + ?Q -> + [?Q, $\\ | Acc]; + %% Escaping solidus is only useful when trying to protect + %% against "</script>" injection attacks which are only + %% possible when JSON is inserted into a HTML document + %% in-line. mochijson2 does not protect you from this, so + %% if you do insert directly into HTML then you need to + %% uncomment the following case or escape the output of encode. + %% + %% $/ -> + %% [$/, $\\ | Acc]; + %% + $\\ -> + [$\\, $\\ | Acc]; + $\b -> + [$b, $\\ | Acc]; + $\f -> + [$f, $\\ | Acc]; + $\n -> + [$n, $\\ | Acc]; + $\r -> + [$r, $\\ | Acc]; + $\t -> + [$t, $\\ | Acc]; + C when C >= 0, C < $\s; C >= 16#7f, C =< 16#10FFFF -> + [unihex(C) | Acc]; + C when C < 16#7f -> + [C | Acc]; + _ -> + exit({json_encode, {bad_char, C}}) + end, + json_encode_string_unicode(Cs, Acc1). + +hexdigit(C) when C >= 0, C =< 9 -> + C + $0; +hexdigit(C) when C =< 15 -> + C + $a - 10. + +unihex(C) when C < 16#10000 -> + <<D3:4, D2:4, D1:4, D0:4>> = <<C:16>>, + Digits = [hexdigit(D) || D <- [D3, D2, D1, D0]], + [$\\, $u | Digits]; +unihex(C) when C =< 16#10FFFF -> + N = C - 16#10000, + S1 = 16#d800 bor ((N bsr 10) band 16#3ff), + S2 = 16#dc00 bor (N band 16#3ff), + [unihex(S1), unihex(S2)]. + +json_decode(L, S) when is_list(L) -> + json_decode(iolist_to_binary(L), S); +json_decode(B, S) -> + {Res, S1} = decode1(B, S), + {eof, _} = tokenize(B, S1#decoder{state=trim}), + Res. + +decode1(B, S=#decoder{state=null}) -> + case tokenize(B, S#decoder{state=any}) of + {{const, C}, S1} -> + {C, S1}; + {start_array, S1} -> + decode_array(B, S1); + {start_object, S1} -> + decode_object(B, S1) + end. + +make_object(V, #decoder{object_hook=null}) -> + V; +make_object(V, #decoder{object_hook=Hook}) -> + Hook(V). + +decode_object(B, S) -> + decode_object(B, S#decoder{state=key}, []). + +decode_object(B, S=#decoder{state=key}, Acc) -> + case tokenize(B, S) of + {end_object, S1} -> + V = make_object({struct, lists:reverse(Acc)}, S1), + {V, S1#decoder{state=null}}; + {{const, K}, S1} -> + {colon, S2} = tokenize(B, S1), + {V, S3} = decode1(B, S2#decoder{state=null}), + decode_object(B, S3#decoder{state=comma}, [{K, V} | Acc]) + end; +decode_object(B, S=#decoder{state=comma}, Acc) -> + case tokenize(B, S) of + {end_object, S1} -> + V = make_object({struct, lists:reverse(Acc)}, S1), + {V, S1#decoder{state=null}}; + {comma, S1} -> + decode_object(B, S1#decoder{state=key}, Acc) + end. + +decode_array(B, S) -> + decode_array(B, S#decoder{state=any}, []). + +decode_array(B, S=#decoder{state=any}, Acc) -> + case tokenize(B, S) of + {end_array, S1} -> + {lists:reverse(Acc), S1#decoder{state=null}}; + {start_array, S1} -> + {Array, S2} = decode_array(B, S1), + decode_array(B, S2#decoder{state=comma}, [Array | Acc]); + {start_object, S1} -> + {Array, S2} = decode_object(B, S1), + decode_array(B, S2#decoder{state=comma}, [Array | Acc]); + {{const, Const}, S1} -> + decode_array(B, S1#decoder{state=comma}, [Const | Acc]) + end; +decode_array(B, S=#decoder{state=comma}, Acc) -> + case tokenize(B, S) of + {end_array, S1} -> + {lists:reverse(Acc), S1#decoder{state=null}}; + {comma, S1} -> + decode_array(B, S1#decoder{state=any}, Acc) + end. + +tokenize_string(B, S) -> + tokenize_string(B, S, []). + +tokenize_string(B, S=#decoder{offset=O}, Acc) -> + case B of + <<_:O/binary, ?Q, _/binary>> -> + {{const, iolist_to_binary(lists:reverse(Acc))}, ?INC_COL(S)}; + <<_:O/binary, "\\\"", _/binary>> -> + tokenize_string(B, ?ADV_COL(S, 2), [$\" | Acc]); + <<_:O/binary, "\\\\", _/binary>> -> + tokenize_string(B, ?ADV_COL(S, 2), [$\\ | Acc]); + <<_:O/binary, "\\/", _/binary>> -> + tokenize_string(B, ?ADV_COL(S, 2), [$/ | Acc]); + <<_:O/binary, "\\b", _/binary>> -> + tokenize_string(B, ?ADV_COL(S, 2), [$\b | Acc]); + <<_:O/binary, "\\f", _/binary>> -> + tokenize_string(B, ?ADV_COL(S, 2), [$\f | Acc]); + <<_:O/binary, "\\n", _/binary>> -> + tokenize_string(B, ?ADV_COL(S, 2), [$\n | Acc]); + <<_:O/binary, "\\r", _/binary>> -> + tokenize_string(B, ?ADV_COL(S, 2), [$\r | Acc]); + <<_:O/binary, "\\t", _/binary>> -> + tokenize_string(B, ?ADV_COL(S, 2), [$\t | Acc]); + <<_:O/binary, "\\u", C3, C2, C1, C0, _/binary>> -> + %% coalesce UTF-16 surrogate pair? + C = erlang:list_to_integer([C3, C2, C1, C0], 16), + Acc1 = lists:reverse(xmerl_ucs:to_utf8(C), Acc), + tokenize_string(B, ?ADV_COL(S, 6), Acc1); + <<_:O/binary, C, _/binary>> -> + tokenize_string(B, ?INC_CHAR(S, C), [C | Acc]) + end. + +tokenize_number(B, S) -> + case tokenize_number(B, sign, S, []) of + {{int, Int}, S1} -> + {{const, list_to_integer(Int)}, S1}; + {{float, Float}, S1} -> + {{const, list_to_float(Float)}, S1} + end. + +tokenize_number(B, sign, S=#decoder{offset=O}, []) -> + case B of + <<_:O/binary, $-, _/binary>> -> + tokenize_number(B, int, ?INC_COL(S), [$-]); + _ -> + tokenize_number(B, int, S, []) + end; +tokenize_number(B, int, S=#decoder{offset=O}, Acc) -> + case B of + <<_:O/binary, $0, _/binary>> -> + tokenize_number(B, frac, ?INC_COL(S), [$0 | Acc]); + <<_:O/binary, C, _/binary>> when C >= $1 andalso C =< $9 -> + tokenize_number(B, int1, ?INC_COL(S), [C | Acc]) + end; +tokenize_number(B, int1, S=#decoder{offset=O}, Acc) -> + case B of + <<_:O/binary, C, _/binary>> when C >= $0 andalso C =< $9 -> + tokenize_number(B, int1, ?INC_COL(S), [C | Acc]); + _ -> + tokenize_number(B, frac, S, Acc) + end; +tokenize_number(B, frac, S=#decoder{offset=O}, Acc) -> + case B of + <<_:O/binary, $., C, _/binary>> when C >= $0, C =< $9 -> + tokenize_number(B, frac1, ?ADV_COL(S, 2), [C, $. | Acc]); + <<_:O/binary, E, _/binary>> when E =:= $e orelse E =:= $E -> + tokenize_number(B, esign, ?INC_COL(S), [$e, $0, $. | Acc]); + _ -> + {{int, lists:reverse(Acc)}, S} + end; +tokenize_number(B, frac1, S=#decoder{offset=O}, Acc) -> + case B of + <<_:O/binary, C, _/binary>> when C >= $0 andalso C =< $9 -> + tokenize_number(B, frac1, ?INC_COL(S), [C | Acc]); + <<_:O/binary, E, _/binary>> when E =:= $e orelse E =:= $E -> + tokenize_number(B, esign, ?INC_COL(S), [$e | Acc]); + _ -> + {{float, lists:reverse(Acc)}, S} + end; +tokenize_number(B, esign, S=#decoder{offset=O}, Acc) -> + case B of + <<_:O/binary, C, _/binary>> when C =:= $- orelse C=:= $+ -> + tokenize_number(B, eint, ?INC_COL(S), [C | Acc]); + _ -> + tokenize_number(B, eint, S, Acc) + end; +tokenize_number(B, eint, S=#decoder{offset=O}, Acc) -> + case B of + <<_:O/binary, C, _/binary>> when C >= $0 andalso C =< $9 -> + tokenize_number(B, eint1, ?INC_COL(S), [C | Acc]) + end; +tokenize_number(B, eint1, S=#decoder{offset=O}, Acc) -> + case B of + <<_:O/binary, C, _/binary>> when C >= $0 andalso C =< $9 -> + tokenize_number(B, eint1, ?INC_COL(S), [C | Acc]); + _ -> + {{float, lists:reverse(Acc)}, S} + end. + +tokenize(B, S=#decoder{offset=O}) -> + case B of + <<_:O/binary, C, _/binary>> when ?IS_WHITESPACE(C) -> + tokenize(B, ?INC_CHAR(S, C)); + <<_:O/binary, "{", _/binary>> -> + {start_object, ?INC_COL(S)}; + <<_:O/binary, "}", _/binary>> -> + {end_object, ?INC_COL(S)}; + <<_:O/binary, "[", _/binary>> -> + {start_array, ?INC_COL(S)}; + <<_:O/binary, "]", _/binary>> -> + {end_array, ?INC_COL(S)}; + <<_:O/binary, ",", _/binary>> -> + {comma, ?INC_COL(S)}; + <<_:O/binary, ":", _/binary>> -> + {colon, ?INC_COL(S)}; + <<_:O/binary, "null", _/binary>> -> + {{const, null}, ?ADV_COL(S, 4)}; + <<_:O/binary, "true", _/binary>> -> + {{const, true}, ?ADV_COL(S, 4)}; + <<_:O/binary, "false", _/binary>> -> + {{const, false}, ?ADV_COL(S, 5)}; + <<_:O/binary, "\"", _/binary>> -> + tokenize_string(B, ?INC_COL(S)); + <<_:O/binary, C, _/binary>> when (C >= $0 andalso C =< $9) + orelse C =:= $- -> + tokenize_number(B, S); + <<_:O/binary>> -> + trim = S#decoder.state, + {eof, S} + end. + +%% testing constructs borrowed from the Yaws JSON implementation. + +%% Create an object from a list of Key/Value pairs. + +obj_new() -> + {struct, []}. + +is_obj({struct, Props}) -> + F = fun ({K, _}) when is_binary(K) -> + true; + (_) -> + false + end, + lists:all(F, Props). + +obj_from_list(Props) -> + Obj = {struct, Props}, + case is_obj(Obj) of + true -> Obj; + false -> exit({json_bad_object, Obj}) + end. + +%% Test for equivalence of Erlang terms. +%% Due to arbitrary order of construction, equivalent objects might +%% compare unequal as erlang terms, so we need to carefully recurse +%% through aggregates (tuples and objects). + +equiv({struct, Props1}, {struct, Props2}) -> + equiv_object(Props1, Props2); +equiv(L1, L2) when is_list(L1), is_list(L2) -> + equiv_list(L1, L2); +equiv(N1, N2) when is_number(N1), is_number(N2) -> N1 == N2; +equiv(B1, B2) when is_binary(B1), is_binary(B2) -> B1 == B2; +equiv(true, true) -> true; +equiv(false, false) -> true; +equiv(null, null) -> true. + +%% Object representation and traversal order is unknown. +%% Use the sledgehammer and sort property lists. + +equiv_object(Props1, Props2) -> + L1 = lists:keysort(1, Props1), + L2 = lists:keysort(1, Props2), + Pairs = lists:zip(L1, L2), + true = lists:all(fun({{K1, V1}, {K2, V2}}) -> + equiv(K1, K2) and equiv(V1, V2) + end, Pairs). + +%% Recursively compare tuple elements for equivalence. + +equiv_list([], []) -> + true; +equiv_list([V1 | L1], [V2 | L2]) -> + case equiv(V1, V2) of + true -> + equiv_list(L1, L2); + false -> + false + end. + +test_all() -> + [1199344435545.0, 1] = decode(<<"[1199344435545.0,1]">>), + test_one(e2j_test_vec(utf8), 1). + +test_one([], _N) -> + %% io:format("~p tests passed~n", [N-1]), + ok; +test_one([{E, J} | Rest], N) -> + %% io:format("[~p] ~p ~p~n", [N, E, J]), + true = equiv(E, decode(J)), + true = equiv(E, decode(encode(E))), + test_one(Rest, 1+N). + +e2j_test_vec(utf8) -> + [ + {1, "1"}, + {3.1416, "3.14160"}, %% text representation may truncate, trail zeroes + {-1, "-1"}, + {-3.1416, "-3.14160"}, + {12.0e10, "1.20000e+11"}, + {1.234E+10, "1.23400e+10"}, + {-1.234E-10, "-1.23400e-10"}, + {10.0, "1.0e+01"}, + {123.456, "1.23456E+2"}, + {10.0, "1e1"}, + {<<"foo">>, "\"foo\""}, + {<<"foo", 5, "bar">>, "\"foo\\u0005bar\""}, + {<<"">>, "\"\""}, + {<<"\n\n\n">>, "\"\\n\\n\\n\""}, + {<<"\" \b\f\r\n\t\"">>, "\"\\\" \\b\\f\\r\\n\\t\\\"\""}, + {obj_new(), "{}"}, + {obj_from_list([{<<"foo">>, <<"bar">>}]), "{\"foo\":\"bar\"}"}, + {obj_from_list([{<<"foo">>, <<"bar">>}, {<<"baz">>, 123}]), + "{\"foo\":\"bar\",\"baz\":123}"}, + {[], "[]"}, + {[[]], "[[]]"}, + {[1, <<"foo">>], "[1,\"foo\"]"}, + + %% json array in a json object + {obj_from_list([{<<"foo">>, [123]}]), + "{\"foo\":[123]}"}, + + %% json object in a json object + {obj_from_list([{<<"foo">>, obj_from_list([{<<"bar">>, true}])}]), + "{\"foo\":{\"bar\":true}}"}, + + %% fold evaluation order + {obj_from_list([{<<"foo">>, []}, + {<<"bar">>, obj_from_list([{<<"baz">>, true}])}, + {<<"alice">>, <<"bob">>}]), + "{\"foo\":[],\"bar\":{\"baz\":true},\"alice\":\"bob\"}"}, + + %% json object in a json array + {[-123, <<"foo">>, obj_from_list([{<<"bar">>, []}]), null], + "[-123,\"foo\",{\"bar\":[]},null]"} + ]. diff --git a/src/mochiweb/mochinum.erl b/src/mochiweb/mochinum.erl new file mode 100644 index 00000000..4f88f9a5 --- /dev/null +++ b/src/mochiweb/mochinum.erl @@ -0,0 +1,289 @@ +%% @copyright 2007 Mochi Media, Inc. +%% @author Bob Ippolito <bob@mochimedia.com> + +%% @doc Useful numeric algorithms for floats that cover some deficiencies +%% in the math module. More interesting is digits/1, which implements +%% the algorithm from: +%% http://www.cs.indiana.edu/~burger/fp/index.html +%% See also "Printing Floating-Point Numbers Quickly and Accurately" +%% in Proceedings of the SIGPLAN '96 Conference on Programming Language +%% Design and Implementation. + +-module(mochinum). +-author("Bob Ippolito <bob@mochimedia.com>"). +-export([digits/1, frexp/1, int_pow/2, int_ceil/1, test/0]). + +%% IEEE 754 Float exponent bias +-define(FLOAT_BIAS, 1022). +-define(MIN_EXP, -1074). +-define(BIG_POW, 4503599627370496). + +%% External API + +%% @spec digits(number()) -> string() +%% @doc Returns a string that accurately represents the given integer or float +%% using a conservative amount of digits. Great for generating +%% human-readable output, or compact ASCII serializations for floats. +digits(N) when is_integer(N) -> + integer_to_list(N); +digits(0.0) -> + "0.0"; +digits(Float) -> + {Frac, Exp} = frexp(Float), + Exp1 = Exp - 53, + Frac1 = trunc(abs(Frac) * (1 bsl 53)), + [Place | Digits] = digits1(Float, Exp1, Frac1), + R = insert_decimal(Place, [$0 + D || D <- Digits]), + case Float < 0 of + true -> + [$- | R]; + _ -> + R + end. + +%% @spec frexp(F::float()) -> {Frac::float(), Exp::float()} +%% @doc Return the fractional and exponent part of an IEEE 754 double, +%% equivalent to the libc function of the same name. +%% F = Frac * pow(2, Exp). +frexp(F) -> + frexp1(unpack(F)). + +%% @spec int_pow(X::integer(), N::integer()) -> Y::integer() +%% @doc Moderately efficient way to exponentiate integers. +%% int_pow(10, 2) = 100. +int_pow(_X, 0) -> + 1; +int_pow(X, N) when N > 0 -> + int_pow(X, N, 1). + +%% @spec int_ceil(F::float()) -> integer() +%% @doc Return the ceiling of F as an integer. The ceiling is defined as +%% F when F == trunc(F); +%% trunc(F) when F < 0; +%% trunc(F) + 1 when F > 0. +int_ceil(X) -> + T = trunc(X), + case (X - T) of + Neg when Neg < 0 -> T; + Pos when Pos > 0 -> T + 1; + _ -> T + end. + + +%% Internal API + +int_pow(X, N, R) when N < 2 -> + R * X; +int_pow(X, N, R) -> + int_pow(X * X, N bsr 1, case N band 1 of 1 -> R * X; 0 -> R end). + +insert_decimal(0, S) -> + "0." ++ S; +insert_decimal(Place, S) when Place > 0 -> + L = length(S), + case Place - L of + 0 -> + S ++ ".0"; + N when N < 0 -> + {S0, S1} = lists:split(L + N, S), + S0 ++ "." ++ S1; + N when N < 6 -> + %% More places than digits + S ++ lists:duplicate(N, $0) ++ ".0"; + _ -> + insert_decimal_exp(Place, S) + end; +insert_decimal(Place, S) when Place > -6 -> + "0." ++ lists:duplicate(abs(Place), $0) ++ S; +insert_decimal(Place, S) -> + insert_decimal_exp(Place, S). + +insert_decimal_exp(Place, S) -> + [C | S0] = S, + S1 = case S0 of + [] -> + "0"; + _ -> + S0 + end, + Exp = case Place < 0 of + true -> + "e-"; + false -> + "e+" + end, + [C] ++ "." ++ S1 ++ Exp ++ integer_to_list(abs(Place - 1)). + + +digits1(Float, Exp, Frac) -> + Round = ((Frac band 1) =:= 0), + case Exp >= 0 of + true -> + BExp = 1 bsl Exp, + case (Frac /= ?BIG_POW) of + true -> + scale((Frac * BExp * 2), 2, BExp, BExp, + Round, Round, Float); + false -> + scale((Frac * BExp * 4), 4, (BExp * 2), BExp, + Round, Round, Float) + end; + false -> + case (Exp == ?MIN_EXP) orelse (Frac /= ?BIG_POW) of + true -> + scale((Frac * 2), 1 bsl (1 - Exp), 1, 1, + Round, Round, Float); + false -> + scale((Frac * 4), 1 bsl (2 - Exp), 2, 1, + Round, Round, Float) + end + end. + +scale(R, S, MPlus, MMinus, LowOk, HighOk, Float) -> + Est = int_ceil(math:log10(abs(Float)) - 1.0e-10), + %% Note that the scheme implementation uses a 326 element look-up table + %% for int_pow(10, N) where we do not. + case Est >= 0 of + true -> + fixup(R, S * int_pow(10, Est), MPlus, MMinus, Est, + LowOk, HighOk); + false -> + Scale = int_pow(10, -Est), + fixup(R * Scale, S, MPlus * Scale, MMinus * Scale, Est, + LowOk, HighOk) + end. + +fixup(R, S, MPlus, MMinus, K, LowOk, HighOk) -> + TooLow = case HighOk of + true -> + (R + MPlus) >= S; + false -> + (R + MPlus) > S + end, + case TooLow of + true -> + [(K + 1) | generate(R, S, MPlus, MMinus, LowOk, HighOk)]; + false -> + [K | generate(R * 10, S, MPlus * 10, MMinus * 10, LowOk, HighOk)] + end. + +generate(R0, S, MPlus, MMinus, LowOk, HighOk) -> + D = R0 div S, + R = R0 rem S, + TC1 = case LowOk of + true -> + R =< MMinus; + false -> + R < MMinus + end, + TC2 = case HighOk of + true -> + (R + MPlus) >= S; + false -> + (R + MPlus) > S + end, + case TC1 of + false -> + case TC2 of + false -> + [D | generate(R * 10, S, MPlus * 10, MMinus * 10, + LowOk, HighOk)]; + true -> + [D + 1] + end; + true -> + case TC2 of + false -> + [D]; + true -> + case R * 2 < S of + true -> + [D]; + false -> + [D + 1] + end + end + end. + +unpack(Float) -> + <<Sign:1, Exp:11, Frac:52>> = <<Float:64/float>>, + {Sign, Exp, Frac}. + +frexp1({_Sign, 0, 0}) -> + {0.0, 0}; +frexp1({Sign, 0, Frac}) -> + Exp = log2floor(Frac), + <<Frac1:64/float>> = <<Sign:1, ?FLOAT_BIAS:11, (Frac-1):52>>, + {Frac1, -(?FLOAT_BIAS) - 52 + Exp}; +frexp1({Sign, Exp, Frac}) -> + <<Frac1:64/float>> = <<Sign:1, ?FLOAT_BIAS:11, Frac:52>>, + {Frac1, Exp - ?FLOAT_BIAS}. + +log2floor(Int) -> + log2floor(Int, 0). + +log2floor(0, N) -> + N; +log2floor(Int, N) -> + log2floor(Int bsr 1, 1 + N). + + +test() -> + ok = test_frexp(), + ok = test_int_ceil(), + ok = test_int_pow(), + ok = test_digits(), + ok. + +test_int_ceil() -> + 1 = int_ceil(0.0001), + 0 = int_ceil(0.0), + 1 = int_ceil(0.99), + 1 = int_ceil(1.0), + -1 = int_ceil(-1.5), + -2 = int_ceil(-2.0), + ok. + +test_int_pow() -> + 1 = int_pow(1, 1), + 1 = int_pow(1, 0), + 1 = int_pow(10, 0), + 10 = int_pow(10, 1), + 100 = int_pow(10, 2), + 1000 = int_pow(10, 3), + ok. + +test_digits() -> + "0" = digits(0), + "0.0" = digits(0.0), + "1.0" = digits(1.0), + "-1.0" = digits(-1.0), + "0.1" = digits(0.1), + "0.01" = digits(0.01), + "0.001" = digits(0.001), + ok. + +test_frexp() -> + %% zero + {0.0, 0} = frexp(0.0), + %% one + {0.5, 1} = frexp(1.0), + %% negative one + {-0.5, 1} = frexp(-1.0), + %% small denormalized number + %% 4.94065645841246544177e-324 + <<SmallDenorm/float>> = <<0,0,0,0,0,0,0,1>>, + {0.5, -1073} = frexp(SmallDenorm), + %% large denormalized number + %% 2.22507385850720088902e-308 + <<BigDenorm/float>> = <<0,15,255,255,255,255,255,255>>, + {0.99999999999999978, -1022} = frexp(BigDenorm), + %% small normalized number + %% 2.22507385850720138309e-308 + <<SmallNorm/float>> = <<0,16,0,0,0,0,0,0>>, + {0.5, -1021} = frexp(SmallNorm), + %% large normalized number + %% 1.79769313486231570815e+308 + <<LargeNorm/float>> = <<127,239,255,255,255,255,255,255>>, + {0.99999999999999989, 1024} = frexp(LargeNorm), + ok. diff --git a/src/mochiweb/mochiweb.app b/src/mochiweb/mochiweb.app new file mode 100644 index 00000000..dea08989 --- /dev/null +++ b/src/mochiweb/mochiweb.app @@ -0,0 +1,29 @@ +{application, mochiweb, + [{description, "MochiMedia Web Server"}, + {vsn, "0.01"}, + {modules, [ + mochihex, + mochijson, + mochijson2, + mochinum, + mochiweb, + mochiweb_app, + mochiweb_charref, + mochiweb_cookies, + mochiweb_echo, + mochiweb_headers, + mochiweb_html, + mochiweb_http, + mochiweb_multipart, + mochiweb_request, + mochiweb_response, + mochiweb_skel, + mochiweb_socket_server, + mochiweb_sup, + mochiweb_util, + reloader + ]}, + {registered, []}, + {mod, {mochiweb_app, []}}, + {env, []}, + {applications, [kernel, stdlib]}]}. diff --git a/src/mochiweb/mochiweb.erl b/src/mochiweb/mochiweb.erl new file mode 100644 index 00000000..6508f304 --- /dev/null +++ b/src/mochiweb/mochiweb.erl @@ -0,0 +1,101 @@ +%% @author Bob Ippolito <bob@mochimedia.com> +%% @copyright 2007 Mochi Media, Inc. + +%% @doc Start and stop the MochiWeb server. + +-module(mochiweb). +-author('bob@mochimedia.com'). + +-export([start/0, stop/0]). +-export([new_request/1, new_response/1]). +-export([all_loaded/0, all_loaded/1, reload/0]). +-export([test/0]). + +%% @spec start() -> ok +%% @doc Start the MochiWeb server. +start() -> + ensure_started(crypto), + application:start(mochiweb). + +%% @spec stop() -> ok +%% @doc Stop the MochiWeb server. +stop() -> + Res = application:stop(mochiweb), + application:stop(crypto), + Res. + +%% @spec test() -> ok +%% @doc Run all of the tests for MochiWeb. +test() -> + mochiweb_util:test(), + mochiweb_headers:test(), + mochiweb_cookies:test(), + mochihex:test(), + mochinum:test(), + mochijson:test(), + mochiweb_charref:test(), + mochiweb_html:test(), + test_request(), + ok. + +reload() -> + [c:l(Module) || Module <- all_loaded()]. + +all_loaded() -> + all_loaded(filename:dirname(code:which(?MODULE))). + +all_loaded(Base) when is_atom(Base) -> + []; +all_loaded(Base) -> + FullBase = Base ++ "/", + F = fun ({_Module, Loaded}, Acc) when is_atom(Loaded) -> + Acc; + ({Module, Loaded}, Acc) -> + case lists:prefix(FullBase, Loaded) of + true -> + [Module | Acc]; + false -> + Acc + end + end, + lists:foldl(F, [], code:all_loaded()). + + +%% @spec new_request({Socket, Request, Headers}) -> MochiWebRequest +%% @doc Return a mochiweb_request data structure. +new_request({Socket, {Method, {abs_path, Uri}, Version}, Headers}) -> + mochiweb_request:new(Socket, + Method, + Uri, + Version, + mochiweb_headers:make(Headers)); +% this case probably doesn't "exist". +new_request({Socket, {Method, {absoluteURI, _Protocol, _Host, _Port, Uri}, + Version}, Headers}) -> + mochiweb_request:new(Socket, + Method, + Uri, + Version, + mochiweb_headers:make(Headers)). + +%% @spec new_response({Request, integer(), Headers}) -> MochiWebResponse +%% @doc Return a mochiweb_response data structure. +new_response({Request, Code, Headers}) -> + mochiweb_response:new(Request, + Code, + mochiweb_headers:make(Headers)). + +%% Internal API + +test_request() -> + R = mochiweb_request:new(z, z, "/foo/bar/baz%20wibble+quux?qs=2", z, []), + "/foo/bar/baz wibble quux" = R:get(path), + ok. + +ensure_started(App) -> + case application:start(App) of + ok -> + ok; + {error, {already_started, App}} -> + ok + end. diff --git a/src/mochiweb/mochiweb_app.erl b/src/mochiweb/mochiweb_app.erl new file mode 100644 index 00000000..2b437f6c --- /dev/null +++ b/src/mochiweb/mochiweb_app.erl @@ -0,0 +1,20 @@ +%% @author Bob Ippolito <bob@mochimedia.com> +%% @copyright 2007 Mochi Media, Inc. + +%% @doc Callbacks for the mochiweb application. + +-module(mochiweb_app). +-author('bob@mochimedia.com'). + +-behaviour(application). +-export([start/2,stop/1]). + +%% @spec start(_Type, _StartArgs) -> ServerRet +%% @doc application start callback for mochiweb. +start(_Type, _StartArgs) -> + mochiweb_sup:start_link(). + +%% @spec stop(_State) -> ServerRet +%% @doc application stop callback for mochiweb. +stop(_State) -> + ok. diff --git a/src/mochiweb/mochiweb_charref.erl b/src/mochiweb/mochiweb_charref.erl new file mode 100644 index 00000000..59fd4a47 --- /dev/null +++ b/src/mochiweb/mochiweb_charref.erl @@ -0,0 +1,295 @@ +%% @author Bob Ippolito <bob@mochimedia.com> +%% @copyright 2007 Mochi Media, Inc. + +%% @doc Converts HTML 4 charrefs and entities to codepoints. +-module(mochiweb_charref). +-export([charref/1, test/0]). + +%% External API. + +%% @spec charref(S) -> integer() | undefined +%% @doc Convert a decimal charref, hex charref, or html entity to a unicode +%% codepoint, or return undefined on failure. +%% The input should not include an ampersand or semicolon. +%% charref("#38") = 38, charref("#x26") = 38, charref("amp") = 38. +charref(B) when is_binary(B) -> + charref(binary_to_list(B)); +charref([$#, C | L]) when C =:= $x orelse C =:= $X -> + try erlang:list_to_integer(L, 16) + catch + error:badarg -> undefined + end; +charref([$# | L]) -> + try list_to_integer(L) + catch + error:badarg -> undefined + end; +charref(L) -> + entity(L). + +%% @spec test() -> ok +%% @doc Run tests for mochiweb_charref. +test() -> + 1234 = charref("#1234"), + 255 = charref("#xfF"), + 255 = charref("#XFf"), + 38 = charref("amp"), + undefined = charref("not_an_entity"), + ok. + +%% Internal API. + +entity("nbsp") -> 160; +entity("iexcl") -> 161; +entity("cent") -> 162; +entity("pound") -> 163; +entity("curren") -> 164; +entity("yen") -> 165; +entity("brvbar") -> 166; +entity("sect") -> 167; +entity("uml") -> 168; +entity("copy") -> 169; +entity("ordf") -> 170; +entity("laquo") -> 171; +entity("not") -> 172; +entity("shy") -> 173; +entity("reg") -> 174; +entity("macr") -> 175; +entity("deg") -> 176; +entity("plusmn") -> 177; +entity("sup2") -> 178; +entity("sup3") -> 179; +entity("acute") -> 180; +entity("micro") -> 181; +entity("para") -> 182; +entity("middot") -> 183; +entity("cedil") -> 184; +entity("sup1") -> 185; +entity("ordm") -> 186; +entity("raquo") -> 187; +entity("frac14") -> 188; +entity("frac12") -> 189; +entity("frac34") -> 190; +entity("iquest") -> 191; +entity("Agrave") -> 192; +entity("Aacute") -> 193; +entity("Acirc") -> 194; +entity("Atilde") -> 195; +entity("Auml") -> 196; +entity("Aring") -> 197; +entity("AElig") -> 198; +entity("Ccedil") -> 199; +entity("Egrave") -> 200; +entity("Eacute") -> 201; +entity("Ecirc") -> 202; +entity("Euml") -> 203; +entity("Igrave") -> 204; +entity("Iacute") -> 205; +entity("Icirc") -> 206; +entity("Iuml") -> 207; +entity("ETH") -> 208; +entity("Ntilde") -> 209; +entity("Ograve") -> 210; +entity("Oacute") -> 211; +entity("Ocirc") -> 212; +entity("Otilde") -> 213; +entity("Ouml") -> 214; +entity("times") -> 215; +entity("Oslash") -> 216; +entity("Ugrave") -> 217; +entity("Uacute") -> 218; +entity("Ucirc") -> 219; +entity("Uuml") -> 220; +entity("Yacute") -> 221; +entity("THORN") -> 222; +entity("szlig") -> 223; +entity("agrave") -> 224; +entity("aacute") -> 225; +entity("acirc") -> 226; +entity("atilde") -> 227; +entity("auml") -> 228; +entity("aring") -> 229; +entity("aelig") -> 230; +entity("ccedil") -> 231; +entity("egrave") -> 232; +entity("eacute") -> 233; +entity("ecirc") -> 234; +entity("euml") -> 235; +entity("igrave") -> 236; +entity("iacute") -> 237; +entity("icirc") -> 238; +entity("iuml") -> 239; +entity("eth") -> 240; +entity("ntilde") -> 241; +entity("ograve") -> 242; +entity("oacute") -> 243; +entity("ocirc") -> 244; +entity("otilde") -> 245; +entity("ouml") -> 246; +entity("divide") -> 247; +entity("oslash") -> 248; +entity("ugrave") -> 249; +entity("uacute") -> 250; +entity("ucirc") -> 251; +entity("uuml") -> 252; +entity("yacute") -> 253; +entity("thorn") -> 254; +entity("yuml") -> 255; +entity("fnof") -> 402; +entity("Alpha") -> 913; +entity("Beta") -> 914; +entity("Gamma") -> 915; +entity("Delta") -> 916; +entity("Epsilon") -> 917; +entity("Zeta") -> 918; +entity("Eta") -> 919; +entity("Theta") -> 920; +entity("Iota") -> 921; +entity("Kappa") -> 922; +entity("Lambda") -> 923; +entity("Mu") -> 924; +entity("Nu") -> 925; +entity("Xi") -> 926; +entity("Omicron") -> 927; +entity("Pi") -> 928; +entity("Rho") -> 929; +entity("Sigma") -> 931; +entity("Tau") -> 932; +entity("Upsilon") -> 933; +entity("Phi") -> 934; +entity("Chi") -> 935; +entity("Psi") -> 936; +entity("Omega") -> 937; +entity("alpha") -> 945; +entity("beta") -> 946; +entity("gamma") -> 947; +entity("delta") -> 948; +entity("epsilon") -> 949; +entity("zeta") -> 950; +entity("eta") -> 951; +entity("theta") -> 952; +entity("iota") -> 953; +entity("kappa") -> 954; +entity("lambda") -> 955; +entity("mu") -> 956; +entity("nu") -> 957; +entity("xi") -> 958; +entity("omicron") -> 959; +entity("pi") -> 960; +entity("rho") -> 961; +entity("sigmaf") -> 962; +entity("sigma") -> 963; +entity("tau") -> 964; +entity("upsilon") -> 965; +entity("phi") -> 966; +entity("chi") -> 967; +entity("psi") -> 968; +entity("omega") -> 969; +entity("thetasym") -> 977; +entity("upsih") -> 978; +entity("piv") -> 982; +entity("bull") -> 8226; +entity("hellip") -> 8230; +entity("prime") -> 8242; +entity("Prime") -> 8243; +entity("oline") -> 8254; +entity("frasl") -> 8260; +entity("weierp") -> 8472; +entity("image") -> 8465; +entity("real") -> 8476; +entity("trade") -> 8482; +entity("alefsym") -> 8501; +entity("larr") -> 8592; +entity("uarr") -> 8593; +entity("rarr") -> 8594; +entity("darr") -> 8595; +entity("harr") -> 8596; +entity("crarr") -> 8629; +entity("lArr") -> 8656; +entity("uArr") -> 8657; +entity("rArr") -> 8658; +entity("dArr") -> 8659; +entity("hArr") -> 8660; +entity("forall") -> 8704; +entity("part") -> 8706; +entity("exist") -> 8707; +entity("empty") -> 8709; +entity("nabla") -> 8711; +entity("isin") -> 8712; +entity("notin") -> 8713; +entity("ni") -> 8715; +entity("prod") -> 8719; +entity("sum") -> 8721; +entity("minus") -> 8722; +entity("lowast") -> 8727; +entity("radic") -> 8730; +entity("prop") -> 8733; +entity("infin") -> 8734; +entity("ang") -> 8736; +entity("and") -> 8743; +entity("or") -> 8744; +entity("cap") -> 8745; +entity("cup") -> 8746; +entity("int") -> 8747; +entity("there4") -> 8756; +entity("sim") -> 8764; +entity("cong") -> 8773; +entity("asymp") -> 8776; +entity("ne") -> 8800; +entity("equiv") -> 8801; +entity("le") -> 8804; +entity("ge") -> 8805; +entity("sub") -> 8834; +entity("sup") -> 8835; +entity("nsub") -> 8836; +entity("sube") -> 8838; +entity("supe") -> 8839; +entity("oplus") -> 8853; +entity("otimes") -> 8855; +entity("perp") -> 8869; +entity("sdot") -> 8901; +entity("lceil") -> 8968; +entity("rceil") -> 8969; +entity("lfloor") -> 8970; +entity("rfloor") -> 8971; +entity("lang") -> 9001; +entity("rang") -> 9002; +entity("loz") -> 9674; +entity("spades") -> 9824; +entity("clubs") -> 9827; +entity("hearts") -> 9829; +entity("diams") -> 9830; +entity("quot") -> 34; +entity("amp") -> 38; +entity("lt") -> 60; +entity("gt") -> 62; +entity("OElig") -> 338; +entity("oelig") -> 339; +entity("Scaron") -> 352; +entity("scaron") -> 353; +entity("Yuml") -> 376; +entity("circ") -> 710; +entity("tilde") -> 732; +entity("ensp") -> 8194; +entity("emsp") -> 8195; +entity("thinsp") -> 8201; +entity("zwnj") -> 8204; +entity("zwj") -> 8205; +entity("lrm") -> 8206; +entity("rlm") -> 8207; +entity("ndash") -> 8211; +entity("mdash") -> 8212; +entity("lsquo") -> 8216; +entity("rsquo") -> 8217; +entity("sbquo") -> 8218; +entity("ldquo") -> 8220; +entity("rdquo") -> 8221; +entity("bdquo") -> 8222; +entity("dagger") -> 8224; +entity("Dagger") -> 8225; +entity("permil") -> 8240; +entity("lsaquo") -> 8249; +entity("rsaquo") -> 8250; +entity("euro") -> 8364; +entity(_) -> undefined. + diff --git a/src/mochiweb/mochiweb_cookies.erl b/src/mochiweb/mochiweb_cookies.erl new file mode 100644 index 00000000..1961233c --- /dev/null +++ b/src/mochiweb/mochiweb_cookies.erl @@ -0,0 +1,250 @@ +%% @author Emad El-Haraty <emad@mochimedia.com> +%% @copyright 2007 Mochi Media, Inc. + +%% @doc HTTP Cookie parsing and generating (RFC 2109, RFC 2965). + +-module(mochiweb_cookies). +-export([parse_cookie/1, cookie/3, cookie/2, test/0]). + +-define(QUOTE, $\"). + +-define(IS_WHITESPACE(C), + (C =:= $\s orelse C =:= $\t orelse C =:= $\r orelse C =:= $\n)). + +%% RFC 2616 separators (called tspecials in RFC 2068) +-define(IS_SEPARATOR(C), + (C < 32 orelse + C =:= $\s orelse C =:= $\t orelse + C =:= $( orelse C =:= $) orelse C =:= $< orelse C =:= $> orelse + C =:= $@ orelse C =:= $, orelse C =:= $; orelse C =:= $: orelse + C =:= $\\ orelse C =:= $\" orelse C =:= $/ orelse + C =:= $[ orelse C =:= $] orelse C =:= $? orelse C =:= $= orelse + C =:= ${ orelse C =:= $})). + +%% @type proplist() = [{Key::string(), Value::string()}]. +%% @type header() = {Name::string(), Value::string()}. + +%% @spec cookie(Key::string(), Value::string()) -> header() +%% @doc Short-hand for <code>cookie(Key, Value, [])</code>. +cookie(Key, Value) -> + cookie(Key, Value, []). + +%% @spec cookie(Key::string(), Value::string(), Options::[Option]) -> header() +%% where Option = {max_age, integer()} | {local_time, {date(), time()}} +%% | {domain, string()} | {path, string()} +%% | {secure, true | false} +%% +%% @doc Generate a Set-Cookie header field tuple. +cookie(Key, Value, Options) -> + Cookie = [any_to_list(Key), "=", quote(Value), "; Version=1"], + %% Set-Cookie: + %% Comment, Domain, Max-Age, Path, Secure, Version + %% Set-Cookie2: + %% Comment, CommentURL, Discard, Domain, Max-Age, Path, Port, Secure, + %% Version + ExpiresPart = + case proplists:get_value(max_age, Options) of + undefined -> + ""; + RawAge -> + When = case proplists:get_value(local_time, Options) of + undefined -> + calendar:local_time(); + LocalTime -> + LocalTime + end, + Age = case RawAge < 0 of + true -> + 0; + false -> + RawAge + end, + ["; Expires=", age_to_cookie_date(Age, When), + "; Max-Age=", quote(Age)] + end, + SecurePart = + case proplists:get_value(secure, Options) of + true -> + "; Secure"; + _ -> + "" + end, + DomainPart = + case proplists:get_value(domain, Options) of + undefined -> + ""; + Domain -> + ["; Domain=", quote(Domain)] + end, + PathPart = + case proplists:get_value(path, Options) of + undefined -> + ""; + Path -> + ["; Path=", quote(Path)] + end, + CookieParts = [Cookie, ExpiresPart, SecurePart, DomainPart, PathPart], + {"Set-Cookie", lists:flatten(CookieParts)}. + + +%% Every major browser incorrectly handles quoted strings in a +%% different and (worse) incompatible manner. Instead of wasting time +%% writing redundant code for each browser, we restrict cookies to +%% only contain characters that browsers handle compatibly. +%% +%% By replacing the definition of quote with this, we generate +%% RFC-compliant cookies: +%% +%% quote(V) -> +%% Fun = fun(?QUOTE, Acc) -> [$\\, ?QUOTE | Acc]; +%% (Ch, Acc) -> [Ch | Acc] +%% end, +%% [?QUOTE | lists:foldr(Fun, [?QUOTE], V)]. + +%% Convert to a string and raise an error if quoting is required. +quote(V0) -> + V = any_to_list(V0), + lists:all(fun(Ch) -> Ch =:= $/ orelse not ?IS_SEPARATOR(Ch) end, V) + orelse erlang:error({cookie_quoting_required, V}), + V. + +add_seconds(Secs, LocalTime) -> + Greg = calendar:datetime_to_gregorian_seconds(LocalTime), + calendar:gregorian_seconds_to_datetime(Greg + Secs). + +age_to_cookie_date(Age, LocalTime) -> + httpd_util:rfc1123_date(add_seconds(Age, LocalTime)). + +%% @spec parse_cookie(string()) -> [{K::string(), V::string()}] +%% @doc Parse the contents of a Cookie header field, ignoring cookie +%% attributes, and return a simple property list. +parse_cookie("") -> + []; +parse_cookie(Cookie) -> + parse_cookie(Cookie, []). + +%% @spec test() -> ok +%% @doc Run tests for mochiweb_cookies. +test() -> + parse_cookie_test(), + cookie_test(), + ok. + +%% Internal API + +parse_cookie([], Acc) -> + lists:reverse(Acc); +parse_cookie(String, Acc) -> + {{Token, Value}, Rest} = read_pair(String), + Acc1 = case Token of + "" -> + Acc; + "$" ++ _ -> + Acc; + _ -> + [{Token, Value} | Acc] + end, + parse_cookie(Rest, Acc1). + +read_pair(String) -> + {Token, Rest} = read_token(skip_whitespace(String)), + {Value, Rest1} = read_value(skip_whitespace(Rest)), + {{Token, Value}, skip_past_separator(Rest1)}. + +read_value([$= | Value]) -> + Value1 = skip_whitespace(Value), + case Value1 of + [?QUOTE | _] -> + read_quoted(Value1); + _ -> + read_token(Value1) + end; +read_value(String) -> + {"", String}. + +read_quoted([?QUOTE | String]) -> + read_quoted(String, []). + +read_quoted([], Acc) -> + {lists:reverse(Acc), []}; +read_quoted([?QUOTE | Rest], Acc) -> + {lists:reverse(Acc), Rest}; +read_quoted([$\\, Any | Rest], Acc) -> + read_quoted(Rest, [Any | Acc]); +read_quoted([C | Rest], Acc) -> + read_quoted(Rest, [C | Acc]). + +skip_whitespace(String) -> + F = fun (C) -> ?IS_WHITESPACE(C) end, + lists:dropwhile(F, String). + +read_token(String) -> + F = fun (C) -> not ?IS_SEPARATOR(C) end, + lists:splitwith(F, String). + +skip_past_separator([]) -> + []; +skip_past_separator([$; | Rest]) -> + Rest; +skip_past_separator([$, | Rest]) -> + Rest; +skip_past_separator([_ | Rest]) -> + skip_past_separator(Rest). + +parse_cookie_test() -> + %% RFC example + C1 = "$Version=\"1\"; Customer=\"WILE_E_COYOTE\"; $Path=\"/acme\"; + Part_Number=\"Rocket_Launcher_0001\"; $Path=\"/acme\"; + Shipping=\"FedEx\"; $Path=\"/acme\"", + [ + {"Customer","WILE_E_COYOTE"}, + {"Part_Number","Rocket_Launcher_0001"}, + {"Shipping","FedEx"} + ] = parse_cookie(C1), + %% Potential edge cases + [{"foo", "x"}] = parse_cookie("foo=\"\\x\""), + [] = parse_cookie("="), + [{"foo", ""}, {"bar", ""}] = parse_cookie(" foo ; bar "), + [{"foo", ""}, {"bar", ""}] = parse_cookie("foo=;bar="), + [{"foo", "\";"}, {"bar", ""}] = parse_cookie("foo = \"\\\";\";bar "), + [{"foo", "\";bar"}] = parse_cookie("foo=\"\\\";bar"). + +any_to_list(V) when is_list(V) -> + V; +any_to_list(V) when is_atom(V) -> + atom_to_list(V); +any_to_list(V) when is_binary(V) -> + binary_to_list(V); +any_to_list(V) when is_integer(V) -> + integer_to_list(V). + + +cookie_test() -> + C1 = {"Set-Cookie", + "Customer=WILE_E_COYOTE; " + "Version=1; " + "Path=/acme"}, + C1 = cookie("Customer", "WILE_E_COYOTE", [{path, "/acme"}]), + C1 = cookie("Customer", "WILE_E_COYOTE", + [{path, "/acme"}, {badoption, "negatory"}]), + C1 = cookie('Customer', 'WILE_E_COYOTE', [{path, '/acme'}]), + C1 = cookie(<<"Customer">>, <<"WILE_E_COYOTE">>, [{path, <<"/acme">>}]), + + {"Set-Cookie","=NoKey; Version=1"} = cookie("", "NoKey", []), + + LocalTime = calendar:universal_time_to_local_time({{2007, 5, 15}, {13, 45, 33}}), + C2 = {"Set-Cookie", + "Customer=WILE_E_COYOTE; " + "Version=1; " + "Expires=Tue, 15 May 2007 13:45:33 GMT; " + "Max-Age=0"}, + C2 = cookie("Customer", "WILE_E_COYOTE", + [{max_age, -111}, {local_time, LocalTime}]), + C3 = {"Set-Cookie", + "Customer=WILE_E_COYOTE; " + "Version=1; " + "Expires=Wed, 16 May 2007 13:45:50 GMT; " + "Max-Age=86417"}, + C3 = cookie("Customer", "WILE_E_COYOTE", + [{max_age, 86417}, {local_time, LocalTime}]), + ok. diff --git a/src/mochiweb/mochiweb_echo.erl b/src/mochiweb/mochiweb_echo.erl new file mode 100644 index 00000000..f164f02a --- /dev/null +++ b/src/mochiweb/mochiweb_echo.erl @@ -0,0 +1,31 @@ +%% @author Bob Ippolito <bob@mochimedia.com> +%% @copyright 2007 Mochi Media, Inc. + +%% @doc Simple and stupid echo server to demo mochiweb_socket_server. + +-module(mochiweb_echo). +-author('bob@mochimedia.com'). +-export([start/0, stop/0, loop/1]). + +stop() -> + mochiweb_socket_server:stop(?MODULE). + +start() -> + mochiweb_socket_server:start([{name, ?MODULE}, + {port, 6789}, + {ip, "127.0.0.1"}, + {max, 1}, + {loop, {?MODULE, loop}}]). + +loop(Socket) -> + case gen_tcp:recv(Socket, 0, 30000) of + {ok, Data} -> + case gen_tcp:send(Socket, Data) of + ok -> + loop(Socket); + _ -> + exit(normal) + end; + _Other -> + exit(normal) + end. diff --git a/src/mochiweb/mochiweb_headers.erl b/src/mochiweb/mochiweb_headers.erl new file mode 100644 index 00000000..5b538aa7 --- /dev/null +++ b/src/mochiweb/mochiweb_headers.erl @@ -0,0 +1,178 @@ +%% @author Bob Ippolito <bob@mochimedia.com> +%% @copyright 2007 Mochi Media, Inc. + +%% @doc Case preserving (but case insensitive) HTTP Header dictionary. + +-module(mochiweb_headers). +-author('bob@mochimedia.com'). +-export([empty/0, from_list/1, insert/3, enter/3, get_value/2, lookup/2]). +-export([get_primary_value/2]). +-export([default/3, enter_from_list/2, default_from_list/2]). +-export([to_list/1, make/1]). +-export([test/0]). + +%% @type headers(). +%% @type key() = atom() | binary() | string(). +%% @type value() = atom() | binary() | string() | integer(). + +%% @spec test() -> ok +%% @doc Run tests for this module. +test() -> + H = ?MODULE:make([{hdr, foo}, {"Hdr", "bar"}, {'Hdr', 2}]), + [{hdr, "foo, bar, 2"}] = ?MODULE:to_list(H), + H1 = ?MODULE:insert(taco, grande, H), + [{hdr, "foo, bar, 2"}, {taco, "grande"}] = ?MODULE:to_list(H1), + H2 = ?MODULE:make([{"Set-Cookie", "foo"}]), + [{"Set-Cookie", "foo"}] = ?MODULE:to_list(H2), + H3 = ?MODULE:insert("Set-Cookie", "bar", H2), + [{"Set-Cookie", "foo"}, {"Set-Cookie", "bar"}] = ?MODULE:to_list(H3), + "foo, bar" = ?MODULE:get_value("set-cookie", H3), + {value, {"Set-Cookie", "foo, bar"}} = ?MODULE:lookup("set-cookie", H3), + undefined = ?MODULE:get_value("shibby", H3), + none = ?MODULE:lookup("shibby", H3), + H4 = ?MODULE:insert("content-type", + "application/x-www-form-urlencoded; charset=utf8", + H3), + "application/x-www-form-urlencoded" = ?MODULE:get_primary_value( + "content-type", H4), + ok. + +%% @spec empty() -> headers() +%% @doc Create an empty headers structure. +empty() -> + gb_trees:empty(). + +%% @spec make(headers() | [{key(), value()}]) -> headers() +%% @doc Construct a headers() from the given list. +make(L) when is_list(L) -> + from_list(L); +%% assume a tuple is already mochiweb_headers. +make(T) when is_tuple(T) -> + T. + +%% @spec from_list([{key(), value()}]) -> headers() +%% @doc Construct a headers() from the given list. +from_list(List) -> + lists:foldl(fun ({K, V}, T) -> insert(K, V, T) end, empty(), List). + +%% @spec enter_from_list([{key(), value()}], headers()) -> headers() +%% @doc Insert pairs into the headers, replace any values for existing keys. +enter_from_list(List, T) -> + lists:foldl(fun ({K, V}, T1) -> enter(K, V, T1) end, T, List). + +%% @spec default_from_list([{key(), value()}], headers()) -> headers() +%% @doc Insert pairs into the headers for keys that do not already exist. +default_from_list(List, T) -> + lists:foldl(fun ({K, V}, T1) -> default(K, V, T1) end, T, List). + +%% @spec to_list(headers()) -> [{key(), string()}] +%% @doc Return the contents of the headers. The keys will be the exact key +%% that was first inserted (e.g. may be an atom or binary, case is +%% preserved). +to_list(T) -> + F = fun ({K, {array, L}}, Acc) -> + L1 = lists:reverse(L), + lists:foldl(fun (V, Acc1) -> [{K, V} | Acc1] end, Acc, L1); + (Pair, Acc) -> + [Pair | Acc] + end, + lists:reverse(lists:foldl(F, [], gb_trees:values(T))). + +%% @spec get_value(key(), headers()) -> string() | undefined +%% @doc Return the value of the given header using a case insensitive search. +%% undefined will be returned for keys that are not present. +get_value(K, T) -> + case lookup(K, T) of + {value, {_, V}} -> + expand(V); + none -> + undefined + end. + +%% @spec get_primary_value(key(), headers()) -> string() | undefined +%% @doc Return the value of the given header up to the first semicolon using +%% a case insensitive search. undefined will be returned for keys +%% that are not present. +get_primary_value(K, T) -> + case get_value(K, T) of + undefined -> + undefined; + V -> + lists:takewhile(fun (C) -> C =/= $; end, V) + end. + +%% @spec lookup(key(), headers()) -> {value, {key(), string()}} | none +%% @doc Return the case preserved key and value for the given header using +%% a case insensitive search. none will be returned for keys that are +%% not present. +lookup(K, T) -> + case gb_trees:lookup(normalize(K), T) of + {value, {K0, V}} -> + {value, {K0, expand(V)}}; + none -> + none + end. + +%% @spec default(key(), value(), headers()) -> headers() +%% @doc Insert the pair into the headers if it does not already exist. +default(K, V, T) -> + K1 = normalize(K), + V1 = any_to_list(V), + try gb_trees:insert(K1, {K, V1}, T) + catch + error:{key_exists, _} -> + T + end. + +%% @spec enter(key(), value(), headers()) -> headers() +%% @doc Insert the pair into the headers, replacing any pre-existing key. +enter(K, V, T) -> + K1 = normalize(K), + V1 = any_to_list(V), + gb_trees:enter(K1, {K, V1}, T). + +%% @spec insert(key(), value(), headers()) -> headers() +%% @doc Insert the pair into the headers, merging with any pre-existing key. +%% A merge is done with Value = V0 ++ ", " ++ V1. +insert(K, V, T) -> + K1 = normalize(K), + V1 = any_to_list(V), + try gb_trees:insert(K1, {K, V1}, T) + catch + error:{key_exists, _} -> + {K0, V0} = gb_trees:get(K1, T), + V2 = merge(K1, V1, V0), + gb_trees:update(K1, {K0, V2}, T) + end. + +%% Internal API + +expand({array, L}) -> + mochiweb_util:join(lists:reverse(L), ", "); +expand(V) -> + V. + +merge("set-cookie", V1, {array, L}) -> + {array, [V1 | L]}; +merge("set-cookie", V1, V0) -> + {array, [V1, V0]}; +merge(_, V1, V0) -> + V0 ++ ", " ++ V1. + +normalize(K) when is_list(K) -> + string:to_lower(K); +normalize(K) when is_atom(K) -> + normalize(atom_to_list(K)); +normalize(K) when is_binary(K) -> + normalize(binary_to_list(K)). + +any_to_list(V) when is_list(V) -> + V; +any_to_list(V) when is_atom(V) -> + atom_to_list(V); +any_to_list(V) when is_binary(V) -> + binary_to_list(V); +any_to_list(V) when is_integer(V) -> + integer_to_list(V). + + diff --git a/src/mochiweb/mochiweb_html.erl b/src/mochiweb/mochiweb_html.erl new file mode 100644 index 00000000..85e6935e --- /dev/null +++ b/src/mochiweb/mochiweb_html.erl @@ -0,0 +1,760 @@ +%% @author Bob Ippolito <bob@mochimedia.com> +%% @copyright 2007 Mochi Media, Inc. + +%% @doc Loosely tokenizes and generates parse trees for HTML 4. +-module(mochiweb_html). +-export([tokens/1, parse/1, parse_tokens/1, to_tokens/1, escape/1, + escape_attr/1, to_html/1, test/0]). + +% This is a macro to placate syntax highlighters.. +-define(QUOTE, $\"). +-define(SQUOTE, $\'). +-define(ADV_COL(S, N), + S#decoder{column=N+S#decoder.column, + offset=N+S#decoder.offset}). +-define(INC_COL(S), + S#decoder{column=1+S#decoder.column, + offset=1+S#decoder.offset}). +-define(INC_LINE(S), + S#decoder{column=1, + line=1+S#decoder.line, + offset=1+S#decoder.offset}). +-define(INC_CHAR(S, C), + case C of + $\n -> + S#decoder{column=1, + line=1+S#decoder.line, + offset=1+S#decoder.offset}; + _ -> + S#decoder{column=1+S#decoder.column, + offset=1+S#decoder.offset} + end). + +-define(IS_WHITESPACE(C), + (C =:= $\s orelse C =:= $\t orelse C =:= $\r orelse C =:= $\n)). +-define(IS_LITERAL_SAFE(C), + ((C >= $A andalso C =< $Z) orelse (C >= $a andalso C =< $z) + orelse (C >= $0 andalso C =< $9))). + +-record(decoder, {line=1, + column=1, + offset=0}). + +%% @type html_node() = {string(), [html_attr()], [html_node() | string()]} +%% @type html_attr() = {string(), string()} +%% @type html_token() = html_data() | start_tag() | end_tag() | inline_html() | html_comment() | html_doctype() +%% @type html_data() = {data, string(), Whitespace::boolean()} +%% @type start_tag() = {start_tag, Name, [html_attr()], Singleton::boolean()} +%% @type end_tag() = {end_tag, Name} +%% @type html_comment() = {comment, Comment} +%% @type html_doctype() = {doctype, [Doctype]} +%% @type inline_html() = {'=', iolist()} + +%% External API. + +%% @spec parse(string() | binary()) -> html_node() +%% @doc tokenize and then transform the token stream into a HTML tree. +parse(Input) -> + parse_tokens(tokens(Input)). + +%% @spec parse_tokens([html_token()]) -> html_node() +%% @doc Transform the output of tokens(Doc) into a HTML tree. +parse_tokens(Tokens) when is_list(Tokens) -> + %% Skip over doctype, processing instructions + F = fun (X) -> + case X of + {start_tag, _, _, false} -> + false; + _ -> + true + end + end, + [{start_tag, Tag, Attrs, false} | Rest] = lists:dropwhile(F, Tokens), + {Tree, _} = tree(Rest, [norm({Tag, Attrs})]), + Tree. + +%% @spec tokens(StringOrBinary) -> [html_token()] +%% @doc Transform the input UTF-8 HTML into a token stream. +tokens(Input) -> + tokens(iolist_to_binary(Input), #decoder{}, []). + +%% @spec to_tokens(html_node()) -> [html_token()] +%% @doc Convert a html_node() tree to a list of tokens. +to_tokens({Tag0}) -> + to_tokens({Tag0, [], []}); +to_tokens(T={'=', _}) -> + [T]; +to_tokens(T={doctype, _}) -> + [T]; +to_tokens(T={comment, _}) -> + [T]; +to_tokens({Tag0, Acc}) -> + to_tokens({Tag0, [], Acc}); +to_tokens({Tag0, Attrs, Acc}) -> + Tag = to_tag(Tag0), + to_tokens([{Tag, Acc}], [{start_tag, Tag, Attrs, is_singleton(Tag)}]). + +%% @spec to_html([html_token()] | html_node()) -> iolist() +%% @doc Convert a list of html_token() to a HTML document. +to_html(Node) when is_tuple(Node) -> + to_html(to_tokens(Node)); +to_html(Tokens) when is_list(Tokens) -> + to_html(Tokens, []). + +%% @spec escape(string() | binary()) -> string() +%% @doc Escape a string such that it's safe for HTML (amp; lt; gt;). +escape(B) when is_binary(B) -> + escape(binary_to_list(B), []); +escape(A) when is_atom(A) -> + escape(atom_to_list(A), []); +escape(S) when is_list(S) -> + escape(S, []). + +%% @spec escape_attr(S::string()) -> string() +%% @doc Escape a string such that it's safe for HTML attrs +%% (amp; lt; gt; quot;). +escape_attr(B) when is_binary(B) -> + escape_attr(binary_to_list(B), []); +escape_attr(A) when is_atom(A) -> + escape_attr(atom_to_list(A), []); +escape_attr(S) when is_list(S) -> + escape_attr(S, []); +escape_attr(I) when is_integer(I) -> + escape_attr(integer_to_list(I), []); +escape_attr(F) when is_float(F) -> + escape_attr(mochinum:digits(F), []). + +%% @spec test() -> ok +%% @doc Run tests for mochiweb_html. +test() -> + test_destack(), + test_tokens(), + test_parse(), + test_parse_tokens(), + test_escape(), + test_escape_attr(), + test_to_html(), + ok. + + +%% Internal API + +test_to_html() -> + Expect = <<"<html><head><title>hey!</title></head><body><p class=\"foo\">what's up<br /></p><div>sucka</div><!-- comment! --></body></html>">>, + Expect = iolist_to_binary( + to_html({html, [], + [{<<"head">>, [], + [{title, <<"hey!">>}]}, + {body, [], + [{p, [{class, foo}], [<<"what's">>, <<" up">>, {br}]}, + {'div', <<"sucka">>}, + {comment, <<" comment! ">>}]}]})), + Expect1 = <<"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">">>, + Expect1 = iolist_to_binary( + to_html({doctype, + [<<"html">>, <<"PUBLIC">>, + <<"-//W3C//DTD XHTML 1.0 Transitional//EN">>, + <<"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">>]})), + ok. +to_html([], Acc) -> + lists:reverse(Acc); +to_html([{'=', Content} | Rest], Acc) -> + to_html(Rest, [Content | Acc]); +to_html([{pi, Tag, Attrs} | Rest], Acc) -> + Open = [<<"<?">>, + Tag, + attrs_to_html(Attrs, []), + <<"?>">>], + to_html(Rest, [Open | Acc]); +to_html([{comment, Comment} | Rest], Acc) -> + to_html(Rest, [[<<"<!--">>, Comment, <<"-->">>] | Acc]); +to_html([{doctype, Parts} | Rest], Acc) -> + Inside = doctype_to_html(Parts, Acc), + to_html(Rest, [[<<"<!DOCTYPE">>, Inside, <<">">>] | Acc]); +to_html([{data, Data, _Whitespace} | Rest], Acc) -> + to_html(Rest, [escape(Data) | Acc]); +to_html([{start_tag, Tag, Attrs, Singleton} | Rest], Acc) -> + Open = [<<"<">>, + Tag, + attrs_to_html(Attrs, []), + case Singleton of + true -> <<" />">>; + false -> <<">">> + end], + to_html(Rest, [Open | Acc]); +to_html([{end_tag, Tag} | Rest], Acc) -> + to_html(Rest, [[<<"</">>, Tag, <<">">>] | Acc]). + +doctype_to_html([], Acc) -> + lists:reverse(Acc); +doctype_to_html([Word | Rest], Acc) -> + case lists:all(fun (C) -> ?IS_LITERAL_SAFE(C) end, + binary_to_list(iolist_to_binary(Word))) of + true -> + doctype_to_html(Rest, [[<<" ">>, Word] | Acc]); + false -> + doctype_to_html(Rest, [[<<" \"">>, escape_attr(Word), ?QUOTE] | Acc]) + end. + +attrs_to_html([], Acc) -> + lists:reverse(Acc); +attrs_to_html([{K, V} | Rest], Acc) -> + attrs_to_html(Rest, + [[<<" ">>, escape(K), <<"=\"">>, + escape_attr(V), <<"\"">>] | Acc]). + +test_escape() -> + <<"&quot;\"word <<up!&quot;">> = + escape(<<""\"word <<up!"">>), + ok. + +test_escape_attr() -> + <<"&quot;"word <<up!&quot;">> = + escape_attr(<<""\"word <<up!"">>), + ok. + +escape([], Acc) -> + list_to_binary(lists:reverse(Acc)); +escape("<" ++ Rest, Acc) -> + escape(Rest, lists:reverse("<", Acc)); +escape(">" ++ Rest, Acc) -> + escape(Rest, lists:reverse(">", Acc)); +escape("&" ++ Rest, Acc) -> + escape(Rest, lists:reverse("&", Acc)); +escape([C | Rest], Acc) -> + escape(Rest, [C | Acc]). + +escape_attr([], Acc) -> + list_to_binary(lists:reverse(Acc)); +escape_attr("<" ++ Rest, Acc) -> + escape_attr(Rest, lists:reverse("<", Acc)); +escape_attr(">" ++ Rest, Acc) -> + escape_attr(Rest, lists:reverse(">", Acc)); +escape_attr("&" ++ Rest, Acc) -> + escape_attr(Rest, lists:reverse("&", Acc)); +escape_attr([?QUOTE | Rest], Acc) -> + escape_attr(Rest, lists:reverse(""", Acc)); +escape_attr([C | Rest], Acc) -> + escape_attr(Rest, [C | Acc]). + +to_tag(A) when is_atom(A) -> + norm(atom_to_list(A)); +to_tag(L) -> + norm(L). + +to_tokens([], Acc) -> + lists:reverse(Acc); +to_tokens([{Tag, []} | Rest], Acc) -> + to_tokens(Rest, [{end_tag, to_tag(Tag)} | Acc]); +to_tokens([{Tag0, [{T0} | R1]} | Rest], Acc) -> + %% Allow {br} + to_tokens([{Tag0, [{T0, [], []} | R1]} | Rest], Acc); +to_tokens([{Tag0, [T0={'=', _C0} | R1]} | Rest], Acc) -> + %% Allow {'=', iolist()} + to_tokens([{Tag0, R1} | Rest], [T0 | Acc]); +to_tokens([{Tag0, [T0={comment, _C0} | R1]} | Rest], Acc) -> + %% Allow {comment, iolist()} + to_tokens([{Tag0, R1} | Rest], [T0 | Acc]); +to_tokens([{Tag0, [{T0, A0=[{_, _} | _]} | R1]} | Rest], Acc) -> + %% Allow {p, [{"class", "foo"}]} + to_tokens([{Tag0, [{T0, A0, []} | R1]} | Rest], Acc); +to_tokens([{Tag0, [{T0, C0} | R1]} | Rest], Acc) -> + %% Allow {p, "content"} and {p, <<"content">>} + to_tokens([{Tag0, [{T0, [], C0} | R1]} | Rest], Acc); +to_tokens([{Tag0, [{T0, A1, C0} | R1]} | Rest], Acc) when is_binary(C0) -> + %% Allow {"p", [{"class", "foo"}], <<"content">>} + to_tokens([{Tag0, [{T0, A1, binary_to_list(C0)} | R1]} | Rest], Acc); +to_tokens([{Tag0, [{T0, A1, C0=[C | _]} | R1]} | Rest], Acc) + when is_integer(C) -> + %% Allow {"p", [{"class", "foo"}], "content"} + to_tokens([{Tag0, [{T0, A1, [C0]} | R1]} | Rest], Acc); +to_tokens([{Tag0, [{T0, A1, C1} | R1]} | Rest], Acc) -> + %% Native {"p", [{"class", "foo"}], ["content"]} + Tag = to_tag(Tag0), + T1 = to_tag(T0), + case is_singleton(norm(T1)) of + true -> + to_tokens([{Tag, R1} | Rest], [{start_tag, T1, A1, true} | Acc]); + false -> + to_tokens([{T1, C1}, {Tag, R1} | Rest], + [{start_tag, T1, A1, false} | Acc]) + end; +to_tokens([{Tag0, [L | R1]} | Rest], Acc) when is_list(L) -> + %% List text + Tag = to_tag(Tag0), + to_tokens([{Tag, R1} | Rest], [{data, iolist_to_binary(L), false} | Acc]); +to_tokens([{Tag0, [B | R1]} | Rest], Acc) when is_binary(B) -> + %% Binary text + Tag = to_tag(Tag0), + to_tokens([{Tag, R1} | Rest], [{data, B, false} | Acc]). + +test_tokens() -> + [{start_tag, <<"foo">>, [{<<"bar">>, <<"baz">>}, + {<<"wibble">>, <<"wibble">>}, + {<<"alice">>, <<"bob">>}], true}] = + tokens(<<"<foo bar=baz wibble='wibble' alice=\"bob\"/>">>), + [{start_tag, <<"foo">>, [{<<"bar">>, <<"baz">>}, + {<<"wibble">>, <<"wibble">>}, + {<<"alice">>, <<"bob">>}], true}] = + tokens(<<"<foo bar=baz wibble='wibble' alice=bob/>">>), + [{comment, <<"[if lt IE 7]>\n<style type=\"text/css\">\n.no_ie { display: none; }\n</style>\n<![endif]">>}] = + tokens(<<"<!--[if lt IE 7]>\n<style type=\"text/css\">\n.no_ie { display: none; }\n</style>\n<![endif]-->">>), + ok. + +tokens(B, S=#decoder{offset=O}, Acc) -> + case B of + <<_:O/binary>> -> + lists:reverse(Acc); + _ -> + {Tag, S1} = tokenize(B, S), + tokens(B, S1, [Tag | Acc]) + end. + +tokenize(B, S=#decoder{offset=O}) -> + case B of + <<_:O/binary, "<!--", _/binary>> -> + tokenize_comment(B, ?ADV_COL(S, 4)); + <<_:O/binary, "<!DOCTYPE", _/binary>> -> + tokenize_doctype(B, ?ADV_COL(S, 10)); + <<_:O/binary, "<![CDATA[", _/binary>> -> + tokenize_cdata(B, ?ADV_COL(S, 9)); + <<_:O/binary, "<?", _/binary>> -> + {Tag, S1} = tokenize_literal(B, ?ADV_COL(S, 2)), + {Attrs, S2} = tokenize_attributes(B, S1), + S3 = find_qgt(B, S2), + {{pi, Tag, Attrs}, S3}; + <<_:O/binary, "&", _/binary>> -> + tokenize_charref(B, ?INC_COL(S)); + <<_:O/binary, "</", _/binary>> -> + {Tag, S1} = tokenize_literal(B, ?ADV_COL(S, 2)), + {S2, _} = find_gt(B, S1), + {{end_tag, Tag}, S2}; + <<_:O/binary, "<", C, _/binary>> when ?IS_WHITESPACE(C) -> + %% This isn't really strict HTML but we want this for markdown + tokenize_data(B, ?INC_COL(S)); + <<_:O/binary, "<", _/binary>> -> + {Tag, S1} = tokenize_literal(B, ?INC_COL(S)), + {Attrs, S2} = tokenize_attributes(B, S1), + {S3, HasSlash} = find_gt(B, S2), + Singleton = HasSlash orelse is_singleton(norm(binary_to_list(Tag))), + {{start_tag, Tag, Attrs, Singleton}, S3}; + _ -> + tokenize_data(B, S) + end. + +test_parse() -> + D0 = <<"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\"> +<html> + <head> + <meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\"> + <title>Foo</title> + <link rel=\"stylesheet\" type=\"text/css\" href=\"/static/rel/dojo/resources/dojo.css\" media=\"screen\"> + <link rel=\"stylesheet\" type=\"text/css\" href=\"/static/foo.css\" media=\"screen\"> + <!--[if lt IE 7]> + <style type=\"text/css\"> + .no_ie { display: none; } + </style> + <![endif]--> + <link rel=\"icon\" href=\"/static/images/favicon.ico\" type=\"image/x-icon\"> + <link rel=\"shortcut icon\" href=\"/static/images/favicon.ico\" type=\"image/x-icon\"> + </head> + <body id=\"home\" class=\"tundra\"><![CDATA[<<this<!-- is -->CDATA>>]]></body> +</html>">>, + Expect = {<<"html">>, [], + [{<<"head">>, [], + [{<<"meta">>, + [{<<"http-equiv">>,<<"Content-Type">>}, + {<<"content">>,<<"text/html; charset=UTF-8">>}], + []}, + {<<"title">>,[],[<<"Foo">>]}, + {<<"link">>, + [{<<"rel">>,<<"stylesheet">>}, + {<<"type">>,<<"text/css">>}, + {<<"href">>,<<"/static/rel/dojo/resources/dojo.css">>}, + {<<"media">>,<<"screen">>}], + []}, + {<<"link">>, + [{<<"rel">>,<<"stylesheet">>}, + {<<"type">>,<<"text/css">>}, + {<<"href">>,<<"/static/foo.css">>}, + {<<"media">>,<<"screen">>}], + []}, + {comment,<<"[if lt IE 7]>\n <style type=\"text/css\">\n .no_ie { display: none; }\n </style>\n <![endif]">>}, + {<<"link">>, + [{<<"rel">>,<<"icon">>}, + {<<"href">>,<<"/static/images/favicon.ico">>}, + {<<"type">>,<<"image/x-icon">>}], + []}, + {<<"link">>, + [{<<"rel">>,<<"shortcut icon">>}, + {<<"href">>,<<"/static/images/favicon.ico">>}, + {<<"type">>,<<"image/x-icon">>}], + []}]}, + {<<"body">>, + [{<<"id">>,<<"home">>}, + {<<"class">>,<<"tundra">>}], + [<<"<<this<!-- is -->CDATA>>">>]}]}, + Expect = parse(D0), + ok. + +test_parse_tokens() -> + D0 = [{doctype,[<<"HTML">>,<<"PUBLIC">>,<<"-//W3C//DTD HTML 4.01 Transitional//EN">>]}, + {data,<<"\n">>,true}, + {start_tag,<<"html">>,[],false}], + {<<"html">>, [], []} = parse_tokens(D0), + D1 = D0 ++ [{end_tag, <<"html">>}], + {<<"html">>, [], []} = parse_tokens(D1), + D2 = D0 ++ [{start_tag, <<"body">>, [], false}], + {<<"html">>, [], [{<<"body">>, [], []}]} = parse_tokens(D2), + D3 = D0 ++ [{start_tag, <<"head">>, [], false}, + {end_tag, <<"head">>}, + {start_tag, <<"body">>, [], false}], + {<<"html">>, [], [{<<"head">>, [], []}, {<<"body">>, [], []}]} = parse_tokens(D3), + D4 = D3 ++ [{data,<<"\n">>,true}, + {start_tag,<<"div">>,[{<<"class">>,<<"a">>}],false}, + {start_tag,<<"a">>,[{<<"name">>,<<"#anchor">>}],false}, + {end_tag,<<"a">>}, + {end_tag,<<"div">>}, + {start_tag,<<"div">>,[{<<"class">>,<<"b">>}],false}, + {start_tag,<<"div">>,[{<<"class">>,<<"c">>}],false}, + {end_tag,<<"div">>}, + {end_tag,<<"div">>}], + {<<"html">>, [], + [{<<"head">>, [], []}, + {<<"body">>, [], + [{<<"div">>, [{<<"class">>, <<"a">>}], [{<<"a">>, [{<<"name">>, <<"#anchor">>}], []}]}, + {<<"div">>, [{<<"class">>, <<"b">>}], [{<<"div">>, [{<<"class">>, <<"c">>}], []}]} + ]}]} = parse_tokens(D4), + D5 = [{start_tag,<<"html">>,[],false}, + {data,<<"\n">>,true}, + {data,<<"boo">>,false}, + {data,<<"hoo">>,false}, + {data,<<"\n">>,true}, + {end_tag,<<"html">>}], + {<<"html">>, [], [<<"\nboohoo\n">>]} = parse_tokens(D5), + D6 = [{start_tag,<<"html">>,[],false}, + {data,<<"\n">>,true}, + {data,<<"\n">>,true}, + {end_tag,<<"html">>}], + {<<"html">>, [], []} = parse_tokens(D6), + D7 = [{start_tag,<<"html">>,[],false}, + {start_tag,<<"ul">>,[],false}, + {start_tag,<<"li">>,[],false}, + {data,<<"word">>,false}, + {start_tag,<<"li">>,[],false}, + {data,<<"up">>,false}, + {end_tag,<<"li">>}, + {start_tag,<<"li">>,[],false}, + {data,<<"fdsa">>,false}, + {start_tag,<<"br">>,[],true}, + {data,<<"asdf">>,false}, + {end_tag,<<"ul">>}, + {end_tag,<<"html">>}], + {<<"html">>, [], + [{<<"ul">>, [], + [{<<"li">>, [], [<<"word">>]}, + {<<"li">>, [], [<<"up">>]}, + {<<"li">>, [], [<<"fdsa">>,{<<"br">>, [], []}, <<"asdf">>]}]}]} = parse_tokens(D7), + ok. + +tree_data([{data, Data, Whitespace} | Rest], AllWhitespace, Acc) -> + tree_data(Rest, (Whitespace andalso AllWhitespace), [Data | Acc]); +tree_data(Rest, AllWhitespace, Acc) -> + {iolist_to_binary(lists:reverse(Acc)), AllWhitespace, Rest}. + +tree([], Stack) -> + {destack(Stack), []}; +tree([{end_tag, Tag} | Rest], Stack) -> + case destack(norm(Tag), Stack) of + S when is_list(S) -> + tree(Rest, S); + Result -> + {Result, []} + end; +tree([{start_tag, Tag, Attrs, true} | Rest], S) -> + tree(Rest, append_stack_child(norm({Tag, Attrs}), S)); +tree([{start_tag, Tag, Attrs, false} | Rest], S) -> + tree(Rest, stack(norm({Tag, Attrs}), S)); +tree([T={pi, _Tag, _Attrs} | Rest], S) -> + tree(Rest, append_stack_child(T, S)); +tree([T={comment, _Comment} | Rest], S) -> + tree(Rest, append_stack_child(T, S)); +tree(L=[{data, _Data, _Whitespace} | _], S) -> + case tree_data(L, true, []) of + {_, true, Rest} -> + tree(Rest, S); + {Data, false, Rest} -> + tree(Rest, append_stack_child(Data, S)) + end. + +norm({Tag, Attrs}) -> + {norm(Tag), [{norm(K), iolist_to_binary(V)} || {K, V} <- Attrs], []}; +norm(Tag) when is_binary(Tag) -> + Tag; +norm(Tag) -> + list_to_binary(string:to_lower(Tag)). + +test_destack() -> + {<<"a">>, [], []} = + destack([{<<"a">>, [], []}]), + {<<"a">>, [], [{<<"b">>, [], []}]} = + destack([{<<"b">>, [], []}, {<<"a">>, [], []}]), + {<<"a">>, [], [{<<"b">>, [], [{<<"c">>, [], []}]}]} = + destack([{<<"c">>, [], []}, {<<"b">>, [], []}, {<<"a">>, [], []}]), + [{<<"a">>, [], [{<<"b">>, [], [{<<"c">>, [], []}]}]}] = + destack(<<"b">>, + [{<<"c">>, [], []}, {<<"b">>, [], []}, {<<"a">>, [], []}]), + [{<<"b">>, [], [{<<"c">>, [], []}]}, {<<"a">>, [], []}] = + destack(<<"c">>, + [{<<"c">>, [], []}, {<<"b">>, [], []},{<<"a">>, [], []}]), + ok. + +stack(T1={TN, _, _}, Stack=[{TN, _, _} | _Rest]) + when TN =:= <<"li">> orelse TN =:= <<"option">> -> + [T1 | destack(TN, Stack)]; +stack(T1={TN0, _, _}, Stack=[{TN1, _, _} | _Rest]) + when (TN0 =:= <<"dd">> orelse TN0 =:= <<"dt">>) andalso + (TN1 =:= <<"dd">> orelse TN1 =:= <<"dt">>) -> + [T1 | destack(TN1, Stack)]; +stack(T1, Stack) -> + [T1 | Stack]. + +append_stack_child(StartTag, [{Name, Attrs, Acc} | Stack]) -> + [{Name, Attrs, [StartTag | Acc]} | Stack]. + +destack(TagName, Stack) when is_list(Stack) -> + F = fun (X) -> + case X of + {TagName, _, _} -> + false; + _ -> + true + end + end, + case lists:splitwith(F, Stack) of + {_, []} -> + %% No match, no state change + Stack; + {_Pre, [_T]} -> + %% Unfurl the whole stack, we're done + destack(Stack); + {Pre, [T, {T0, A0, Acc0} | Post]} -> + %% Unfurl up to the tag, then accumulate it + [{T0, A0, [destack(Pre ++ [T]) | Acc0]} | Post] + end. + +destack([{Tag, Attrs, Acc}]) -> + {Tag, Attrs, lists:reverse(Acc)}; +destack([{T1, A1, Acc1}, {T0, A0, Acc0} | Rest]) -> + destack([{T0, A0, [{T1, A1, lists:reverse(Acc1)} | Acc0]} | Rest]). + +is_singleton(<<"br">>) -> true; +is_singleton(<<"hr">>) -> true; +is_singleton(<<"img">>) -> true; +is_singleton(<<"input">>) -> true; +is_singleton(<<"base">>) -> true; +is_singleton(<<"meta">>) -> true; +is_singleton(<<"link">>) -> true; +is_singleton(<<"area">>) -> true; +is_singleton(<<"param">>) -> true; +is_singleton(<<"col">>) -> true; +is_singleton(_) -> false. + +tokenize_data(B, S=#decoder{offset=O}) -> + tokenize_data(B, S, O, true). + +tokenize_data(B, S=#decoder{offset=O}, Start, Whitespace) -> + case B of + <<_:O/binary, C, _/binary>> when (C =/= $< andalso C =/= $&) -> + tokenize_data(B, ?INC_CHAR(S, C), Start, + (Whitespace andalso ?IS_WHITESPACE(C))); + _ -> + Len = O - Start, + <<_:Start/binary, Data:Len/binary, _/binary>> = B, + {{data, Data, Whitespace}, S} + end. + +tokenize_attributes(B, S) -> + tokenize_attributes(B, S, []). + +tokenize_attributes(B, S=#decoder{offset=O}, Acc) -> + case B of + <<_:O/binary>> -> + {lists:reverse(Acc), S}; + <<_:O/binary, C, _/binary>> when (C =:= $> orelse C =:= $/) -> + {lists:reverse(Acc), S}; + <<_:O/binary, "?>", _/binary>> -> + {lists:reverse(Acc), S}; + <<_:O/binary, C, _/binary>> when ?IS_WHITESPACE(C) -> + tokenize_attributes(B, ?INC_CHAR(S, C), Acc); + _ -> + {Attr, S1} = tokenize_literal(B, S), + {Value, S2} = tokenize_attr_value(Attr, B, S1), + tokenize_attributes(B, S2, [{Attr, Value} | Acc]) + end. + +tokenize_attr_value(Attr, B, S) -> + S1 = skip_whitespace(B, S), + O = S1#decoder.offset, + case B of + <<_:O/binary, "=", _/binary>> -> + tokenize_word_or_literal(B, ?INC_COL(S1)); + _ -> + {Attr, S1} + end. + +skip_whitespace(B, S=#decoder{offset=O}) -> + case B of + <<_:O/binary, C, _/binary>> when ?IS_WHITESPACE(C) -> + skip_whitespace(B, ?INC_CHAR(S, C)); + _ -> + S + end. + +tokenize_literal(Bin, S) -> + tokenize_literal(Bin, S, []). + +tokenize_literal(Bin, S=#decoder{offset=O}, Acc) -> + case Bin of + <<_:O/binary, $&, _/binary>> -> + {{data, Data, false}, S1} = tokenize_charref(Bin, ?INC_COL(S)), + tokenize_literal(Bin, S1, [Data | Acc]); + <<_:O/binary, C, _/binary>> when not (?IS_WHITESPACE(C) + orelse C =:= $> + orelse C =:= $/ + orelse C =:= $=) -> + tokenize_literal(Bin, ?INC_COL(S), [C | Acc]); + _ -> + {iolist_to_binary(lists:reverse(Acc)), S} + end. + +find_qgt(Bin, S=#decoder{offset=O}) -> + case Bin of + <<_:O/binary, "?>", _/binary>> -> + ?ADV_COL(S, 2); + <<_:O/binary, C, _/binary>> -> + find_qgt(Bin, ?INC_CHAR(S, C)); + _ -> + S + end. + +find_gt(Bin, S) -> + find_gt(Bin, S, false). + +find_gt(Bin, S=#decoder{offset=O}, HasSlash) -> + case Bin of + <<_:O/binary, $/, _/binary>> -> + find_gt(Bin, ?INC_COL(S), true); + <<_:O/binary, $>, _/binary>> -> + {?INC_COL(S), HasSlash}; + <<_:O/binary, C, _/binary>> -> + find_gt(Bin, ?INC_CHAR(S, C), HasSlash); + _ -> + {S, HasSlash} + end. + +tokenize_charref(Bin, S=#decoder{offset=O}) -> + tokenize_charref(Bin, S, O). + +tokenize_charref(Bin, S=#decoder{offset=O}, Start) -> + case Bin of + <<_:O/binary>> -> + <<_:Start/binary, Raw/binary>> = Bin, + {{data, Raw, false}, S}; + <<_:O/binary, C, _/binary>> when ?IS_WHITESPACE(C) + orelse C =:= ?SQUOTE + orelse C =:= ?QUOTE + orelse C =:= $/ + orelse C =:= $> -> + Len = O - Start, + <<_:Start/binary, Raw:Len/binary, _/binary>> = Bin, + {{data, Raw, false}, S}; + <<_:O/binary, $;, _/binary>> -> + Len = O - Start, + <<_:Start/binary, Raw:Len/binary, _/binary>> = Bin, + Data = case mochiweb_charref:charref(Raw) of + undefined -> + Start1 = Start - 1, + Len1 = Len + 2, + <<_:Start1/binary, R:Len1/binary, _/binary>> = Bin, + R; + Unichar -> + list_to_binary(xmerl_ucs:to_utf8(Unichar)) + end, + {{data, Data, false}, ?INC_COL(S)}; + _ -> + tokenize_charref(Bin, ?INC_COL(S), Start) + end. + +tokenize_doctype(Bin, S) -> + tokenize_doctype(Bin, S, []). + +tokenize_doctype(Bin, S=#decoder{offset=O}, Acc) -> + case Bin of + <<_:O/binary>> -> + {{doctype, lists:reverse(Acc)}, S}; + <<_:O/binary, $>, _/binary>> -> + {{doctype, lists:reverse(Acc)}, ?INC_COL(S)}; + <<_:O/binary, C, _/binary>> when ?IS_WHITESPACE(C) -> + tokenize_doctype(Bin, ?INC_CHAR(S, C), Acc); + _ -> + {Word, S1} = tokenize_word_or_literal(Bin, S), + tokenize_doctype(Bin, S1, [Word | Acc]) + end. + +tokenize_word_or_literal(Bin, S=#decoder{offset=O}) -> + case Bin of + <<_:O/binary, C, _/binary>> when ?IS_WHITESPACE(C) -> + {error, {whitespace, [C], S}}; + <<_:O/binary, C, _/binary>> when C =:= ?QUOTE orelse C =:= ?SQUOTE -> + tokenize_word(Bin, ?INC_COL(S), C); + _ -> + tokenize_literal(Bin, S, []) + end. + +tokenize_word(Bin, S, Quote) -> + tokenize_word(Bin, S, Quote, []). + +tokenize_word(Bin, S=#decoder{offset=O}, Quote, Acc) -> + case Bin of + <<_:O/binary>> -> + {iolist_to_binary(lists:reverse(Acc)), S}; + <<_:O/binary, Quote, _/binary>> -> + {iolist_to_binary(lists:reverse(Acc)), ?INC_COL(S)}; + <<_:O/binary, $&, _/binary>> -> + {{data, Data, false}, S1} = tokenize_charref(Bin, ?INC_COL(S)), + tokenize_word(Bin, S1, Quote, [Data | Acc]); + <<_:O/binary, C, _/binary>> -> + tokenize_word(Bin, ?INC_CHAR(S, C), Quote, [C | Acc]) + end. + +tokenize_cdata(Bin, S=#decoder{offset=O}) -> + tokenize_cdata(Bin, S, O). + +tokenize_cdata(Bin, S=#decoder{offset=O}, Start) -> + case Bin of + <<_:O/binary, "]]>", _/binary>> -> + Len = O - Start, + <<_:Start/binary, Raw:Len/binary, _/binary>> = Bin, + {{data, Raw, false}, ?ADV_COL(S, 3)}; + <<_:O/binary, C, _/binary>> -> + tokenize_cdata(Bin, ?INC_CHAR(S, C), Start); + _ -> + <<_:O/binary, Raw/binary>> = Bin, + {{data, Raw, false}, S} + end. + +tokenize_comment(Bin, S=#decoder{offset=O}) -> + tokenize_comment(Bin, S, O). + +tokenize_comment(Bin, S=#decoder{offset=O}, Start) -> + case Bin of + <<_:O/binary, "-->", _/binary>> -> + Len = O - Start, + <<_:Start/binary, Raw:Len/binary, _/binary>> = Bin, + {{comment, Raw}, ?ADV_COL(S, 3)}; + <<_:O/binary, C, _/binary>> -> + tokenize_comment(Bin, ?INC_CHAR(S, C), Start); + <<_:Start/binary, Raw/binary>> -> + {{comment, Raw}, S} + end. diff --git a/src/mochiweb/mochiweb_http.erl b/src/mochiweb/mochiweb_http.erl new file mode 100644 index 00000000..10c51220 --- /dev/null +++ b/src/mochiweb/mochiweb_http.erl @@ -0,0 +1,132 @@ +%% @author Bob Ippolito <bob@mochimedia.com> +%% @copyright 2007 Mochi Media, Inc. + +%% @doc HTTP server. + +-module(mochiweb_http). +-author('bob@mochimedia.com'). +-export([start/0, start/1, stop/0, stop/1]). +-export([loop/2, default_body/1]). + +-define(IDLE_TIMEOUT, 30000). + +-define(DEFAULTS, [{name, ?MODULE}, + {port, 8888}]). + +set_default({Prop, Value}, PropList) -> + case proplists:is_defined(Prop, PropList) of + true -> + PropList; + false -> + [{Prop, Value} | PropList] + end. + +set_defaults(Defaults, PropList) -> + lists:foldl(fun set_default/2, PropList, Defaults). + +parse_options(Options) -> + {loop, HttpLoop} = proplists:lookup(loop, Options), + Loop = fun (S) -> + ?MODULE:loop(S, HttpLoop) + end, + Options1 = [{loop, Loop} | proplists:delete(loop, Options)], + set_defaults(?DEFAULTS, Options1). + +stop() -> + mochiweb_socket_server:stop(?MODULE). + +stop(Name) -> + mochiweb_socket_server:stop(Name). + +start() -> + start([{ip, "127.0.0.1"}, + {loop, {?MODULE, default_body}}]). + +start(Options) -> + mochiweb_socket_server:start(parse_options(Options)). + +frm(Body) -> + ["<html><head></head><body>" + "<form method=\"POST\">" + "<input type=\"hidden\" value=\"message\" name=\"hidden\"/>" + "<input type=\"submit\" value=\"regular POST\">" + "</form>" + "<br />" + "<form method=\"POST\" enctype=\"multipart/form-data\"" + " action=\"/multipart\">" + "<input type=\"hidden\" value=\"multipart message\" name=\"hidden\"/>" + "<input type=\"file\" name=\"file\"/>" + "<input type=\"submit\" value=\"multipart POST\" />" + "</form>" + "<pre>", Body, "</pre>" + "</body></html>"]. + +default_body(Req, M, "/chunked") when M =:= 'GET'; M =:= 'HEAD' -> + Res = Req:ok({"text/plain", [], chunked}), + Res:write_chunk("First chunk\r\n"), + timer:sleep(5000), + Res:write_chunk("Last chunk\r\n"), + Res:write_chunk(""); +default_body(Req, M, _Path) when M =:= 'GET'; M =:= 'HEAD' -> + Body = io_lib:format("~p~n", [[{parse_qs, Req:parse_qs()}, + {parse_cookie, Req:parse_cookie()}, + Req:dump()]]), + Req:ok({"text/html", + [mochiweb_cookies:cookie("mochiweb_http", "test_cookie")], + frm(Body)}); +default_body(Req, 'POST', "/multipart") -> + Body = io_lib:format("~p~n", [[{parse_qs, Req:parse_qs()}, + {parse_cookie, Req:parse_cookie()}, + {body, Req:recv_body()}, + Req:dump()]]), + Req:ok({"text/html", [], frm(Body)}); +default_body(Req, 'POST', _Path) -> + Body = io_lib:format("~p~n", [[{parse_qs, Req:parse_qs()}, + {parse_cookie, Req:parse_cookie()}, + {parse_post, Req:parse_post()}, + Req:dump()]]), + Req:ok({"text/html", [], frm(Body)}); +default_body(Req, _Method, _Path) -> + Req:respond({501, [], []}). + +default_body(Req) -> + default_body(Req, Req:get(method), Req:get(path)). + +loop(Socket, Body) -> + inet:setopts(Socket, [{packet, http}]), + request(Socket, Body). + +request(Socket, Body) -> + case gen_tcp:recv(Socket, 0, ?IDLE_TIMEOUT) of + {ok, {http_request, Method, Path, Version}} -> + headers(Socket, {Method, Path, Version}, [], Body); + {error, {http_error, "\r\n"}} -> + request(Socket, Body); + {error, {http_error, "\n"}} -> + request(Socket, Body); + _Other -> + gen_tcp:close(Socket), + exit(normal) + end. + +headers(Socket, Request, Headers, Body) -> + case gen_tcp:recv(Socket, 0, ?IDLE_TIMEOUT) of + {ok, http_eoh} -> + inet:setopts(Socket, [{packet, raw}]), + Req = mochiweb:new_request({Socket, Request, + lists:reverse(Headers)}), + Body(Req), + case Req:should_close() of + true -> + gen_tcp:close(Socket), + exit(normal); + false -> + Req:cleanup(), + ?MODULE:loop(Socket, Body) + end; + {ok, {http_header, _, Name, _, Value}} -> + headers(Socket, Request, [{Name, Value} | Headers], Body); + _Other -> + gen_tcp:close(Socket), + exit(normal) + end. diff --git a/src/mochiweb/mochiweb_multipart.erl b/src/mochiweb/mochiweb_multipart.erl new file mode 100644 index 00000000..804273cb --- /dev/null +++ b/src/mochiweb/mochiweb_multipart.erl @@ -0,0 +1,428 @@ +%% @author Bob Ippolito <bob@mochimedia.com> +%% @copyright 2007 Mochi Media, Inc. + +%% @doc Utilities for parsing multipart/form-data. + +-module(mochiweb_multipart). +-author('bob@mochimedia.com'). + +-export([parse_form/2]). +-export([parse_multipart_request/2]). +-export([test/0]). + +-define(CHUNKSIZE, 4096). + +-record(mp, {state, boundary, length, buffer, callback, req}). + +%% TODO: DOCUMENT THIS MODULE. + +parse_form(Req, FileHandler) -> + Callback = fun (Next) -> parse_form_outer(Next, FileHandler, []) end, + {_, _, Res} = parse_multipart_request(Req, Callback), + Res. + +parse_form_outer(eof, _, Acc) -> + lists:reverse(Acc); +parse_form_outer({headers, H}, FileHandler, State) -> + {"form-data", H1} = proplists:get_value("content-disposition", H), + Name = proplists:get_value("name", H1), + Filename = proplists:get_value("filename", H1), + case Filename of + undefined -> + fun (Next) -> + parse_form_value(Next, {Name, []}, FileHandler, State) + end; + _ -> + ContentType = proplists:get_value("content-type", H), + Handler = FileHandler(Filename, ContentType), + fun (Next) -> + parse_form_file(Next, {Name, Handler}, FileHandler, State) + end + end. + +parse_form_value(body_end, {Name, Acc}, FileHandler, State) -> + Value = binary_to_list(iolist_to_binary(lists:reverse(Acc))), + State1 = [{Name, Value} | State], + fun (Next) -> parse_form_outer(Next, FileHandler, State1) end; +parse_form_value({body, Data}, {Name, Acc}, FileHandler, State) -> + Acc1 = [Data | Acc], + fun (Next) -> parse_form_value(Next, {Name, Acc1}, FileHandler, State) end. + +parse_form_file(body_end, {Name, Handler}, FileHandler, State) -> + Value = Handler(eof), + State1 = [{Name, Value} | State], + fun (Next) -> parse_form_outer(Next, FileHandler, State1) end; +parse_form_file({body, Data}, {Name, Handler}, FileHandler, State) -> + H1 = Handler(Data), + fun (Next) -> parse_form_file(Next, {Name, H1}, FileHandler, State) end. + +parse_multipart_request(Req, Callback) -> + %% TODO: Support chunked? + Length = list_to_integer(Req:get_header_value("content-length")), + Boundary = iolist_to_binary( + get_boundary(Req:get_header_value("content-type"))), + Prefix = <<"\r\n--", Boundary/binary>>, + BS = size(Boundary), + Chunk = read_chunk(Req, Length), + Length1 = Length - size(Chunk), + <<"--", Boundary:BS/binary, "\r\n", Rest/binary>> = Chunk, + feed_mp(headers, #mp{boundary=Prefix, + length=Length1, + buffer=Rest, + callback=Callback, + req=Req}). + +parse_headers(<<>>) -> + []; +parse_headers(Binary) -> + parse_headers(Binary, []). + +parse_headers(Binary, Acc) -> + case find_in_binary(<<"\r\n">>, Binary) of + {exact, N} -> + <<Line:N/binary, "\r\n", Rest/binary>> = Binary, + parse_headers(Rest, [split_header(Line) | Acc]); + not_found -> + lists:reverse([split_header(Binary) | Acc]) + end. + +split_header(Line) -> + {Name, [$: | Value]} = lists:splitwith(fun (C) -> C =/= $: end, + binary_to_list(Line)), + {string:to_lower(string:strip(Name)), + mochiweb_util:parse_header(Value)}. + +read_chunk(Req, Length) when Length > 0 -> + case Length of + Length when Length < ?CHUNKSIZE -> + Req:recv(Length); + _ -> + Req:recv(?CHUNKSIZE) + end. + +read_more(State=#mp{length=Length, buffer=Buffer, req=Req}) -> + Data = read_chunk(Req, Length), + Buffer1 = <<Buffer/binary, Data/binary>>, + State#mp{length=Length - size(Data), + buffer=Buffer1}. + +feed_mp(headers, State=#mp{buffer=Buffer, callback=Callback}) -> + {State1, P} = case find_in_binary(<<"\r\n\r\n">>, Buffer) of + {exact, N} -> + {State, N}; + _ -> + S1 = read_more(State), + %% Assume headers must be less than ?CHUNKSIZE + {exact, N} = find_in_binary(<<"\r\n\r\n">>, + S1#mp.buffer), + {S1, N} + end, + <<Headers:P/binary, "\r\n\r\n", Rest/binary>> = State1#mp.buffer, + NextCallback = Callback({headers, parse_headers(Headers)}), + feed_mp(body, State1#mp{buffer=Rest, + callback=NextCallback}); +feed_mp(body, State=#mp{boundary=Prefix, buffer=Buffer, callback=Callback}) -> + case find_boundary(Prefix, Buffer) of + {end_boundary, Start, Skip} -> + <<Data:Start/binary, _:Skip/binary, Rest/binary>> = Buffer, + C1 = Callback({body, Data}), + C2 = C1(body_end), + {State#mp.length, Rest, C2(eof)}; + {next_boundary, Start, Skip} -> + <<Data:Start/binary, _:Skip/binary, Rest/binary>> = Buffer, + C1 = Callback({body, Data}), + feed_mp(headers, State#mp{callback=C1(body_end), + buffer=Rest}); + {maybe, Start} -> + <<Data:Start/binary, Rest/binary>> = Buffer, + feed_mp(body, read_more(State#mp{callback=Callback({body, Data}), + buffer=Rest})); + not_found -> + {Data, Rest} = {Buffer, <<>>}, + feed_mp(body, read_more(State#mp{callback=Callback({body, Data}), + buffer=Rest})) + end. + +get_boundary(ContentType) -> + {"multipart/form-data", Opts} = mochiweb_util:parse_header(ContentType), + case proplists:get_value("boundary", Opts) of + S when is_list(S) -> + S + end. + +find_in_binary(B, Data) when size(B) > 0 -> + case size(Data) - size(B) of + Last when Last < 0 -> + partial_find(B, Data, 0, size(Data)); + Last -> + find_in_binary(B, size(B), Data, 0, Last) + end. + +find_in_binary(B, BS, D, N, Last) when N =< Last-> + case D of + <<_:N/binary, B:BS/binary, _/binary>> -> + {exact, N}; + _ -> + find_in_binary(B, BS, D, 1 + N, Last) + end; +find_in_binary(B, BS, D, N, Last) when N =:= 1 + Last -> + partial_find(B, D, N, BS - 1). + +partial_find(_B, _D, _N, 0) -> + not_found; +partial_find(B, D, N, K) -> + <<B1:K/binary, _/binary>> = B, + case D of + <<_Skip:N/binary, B1:K/binary>> -> + {partial, N, K}; + _ -> + partial_find(B, D, 1 + N, K - 1) + end. + +find_boundary(Prefix, Data) -> + case find_in_binary(Prefix, Data) of + {exact, Skip} -> + PrefixSkip = Skip + size(Prefix), + case Data of + <<_:PrefixSkip/binary, "\r\n", _/binary>> -> + {next_boundary, Skip, size(Prefix) + 2}; + <<_:PrefixSkip/binary, "--\r\n", _/binary>> -> + {end_boundary, Skip, size(Prefix) + 4}; + _ when size(Data) < PrefixSkip + 4 -> + %% Underflow + {maybe, Skip}; + _ -> + %% False positive + not_found + end; + {partial, Skip, Length} when (Skip + Length) =:= size(Data) -> + %% Underflow + {maybe, Skip}; + _ -> + not_found + end. + +with_socket_server(ServerFun, ClientFun) -> + {ok, Server} = mochiweb_socket_server:start([{ip, "127.0.0.1"}, + {port, 0}, + {loop, ServerFun}]), + Port = mochiweb_socket_server:get(Server, port), + {ok, Client} = gen_tcp:connect("127.0.0.1", Port, + [binary, {active, false}]), + Res = (catch ClientFun(Client)), + mochiweb_socket_server:stop(Server), + Res. + +fake_request(Socket, ContentType, Length) -> + mochiweb_request:new(Socket, + 'POST', + "/multipart", + {1,1}, + mochiweb_headers:make( + [{"content-type", ContentType}, + {"content-length", Length}])). + +test_callback(Expect, [Expect | Rest]) -> + case Rest of + [] -> + ok; + _ -> + fun (Next) -> test_callback(Next, Rest) end + end. + +test_parse3() -> + ContentType = "multipart/form-data; boundary=---------------------------7386909285754635891697677882", + BinContent = <<"-----------------------------7386909285754635891697677882\r\nContent-Disposition: form-data; name=\"hidden\"\r\n\r\nmultipart message\r\n-----------------------------7386909285754635891697677882\r\nContent-Disposition: form-data; name=\"file\"; filename=\"test_file.txt\"\r\nContent-Type: text/plain\r\n\r\nWoo multiline text file\n\nLa la la\r\n-----------------------------7386909285754635891697677882--\r\n">>, + Expect = [{headers, + [{"content-disposition", + {"form-data", [{"name", "hidden"}]}}]}, + {body, <<"multipart message">>}, + body_end, + {headers, + [{"content-disposition", + {"form-data", [{"name", "file"}, {"filename", "test_file.txt"}]}}, + {"content-type", {"text/plain", []}}]}, + {body, <<"Woo multiline text file\n\nLa la la">>}, + body_end, + eof], + TestCallback = fun (Next) -> test_callback(Next, Expect) end, + ServerFun = fun (Socket) -> + case gen_tcp:send(Socket, BinContent) of + ok -> + exit(normal) + end + end, + ClientFun = fun (Socket) -> + Req = fake_request(Socket, ContentType, + size(BinContent)), + Res = parse_multipart_request(Req, TestCallback), + {0, <<>>, ok} = Res, + ok + end, + ok = with_socket_server(ServerFun, ClientFun), + ok. + + +test_parse2() -> + ContentType = "multipart/form-data; boundary=---------------------------6072231407570234361599764024", + BinContent = <<"-----------------------------6072231407570234361599764024\r\nContent-Disposition: form-data; name=\"hidden\"\r\n\r\nmultipart message\r\n-----------------------------6072231407570234361599764024\r\nContent-Disposition: form-data; name=\"file\"; filename=\"\"\r\nContent-Type: application/octet-stream\r\n\r\n\r\n-----------------------------6072231407570234361599764024--\r\n">>, + Expect = [{headers, + [{"content-disposition", + {"form-data", [{"name", "hidden"}]}}]}, + {body, <<"multipart message">>}, + body_end, + {headers, + [{"content-disposition", + {"form-data", [{"name", "file"}, {"filename", ""}]}}, + {"content-type", {"application/octet-stream", []}}]}, + {body, <<>>}, + body_end, + eof], + TestCallback = fun (Next) -> test_callback(Next, Expect) end, + ServerFun = fun (Socket) -> + case gen_tcp:send(Socket, BinContent) of + ok -> + exit(normal) + end + end, + ClientFun = fun (Socket) -> + Req = fake_request(Socket, ContentType, + size(BinContent)), + Res = parse_multipart_request(Req, TestCallback), + {0, <<>>, ok} = Res, + ok + end, + ok = with_socket_server(ServerFun, ClientFun), + ok. + +handler_test(Filename, ContentType) -> + fun (Next) -> + handler_test_read(Next, {Filename, ContentType}, []) + end. + +handler_test_read(eof, {Filename, ContentType}, Acc) -> + Value = iolist_to_binary(lists:reverse(Acc)), + {Filename, ContentType, Value}; +handler_test_read(Data, H, Acc) -> + Acc1 = [Data | Acc], + fun (Next) -> handler_test_read(Next, H, Acc1) end. + + +test_parse_form() -> + ContentType = "multipart/form-data; boundary=AaB03x", + "AaB03x" = get_boundary(ContentType), + Content = mochiweb_util:join( + ["--AaB03x", + "Content-Disposition: form-data; name=\"submit-name\"", + "", + "Larry", + "--AaB03x", + "Content-Disposition: form-data; name=\"files\";" + ++ "filename=\"file1.txt\"", + "Content-Type: text/plain", + "", + "... contents of file1.txt ...", + "--AaB03x--", + ""], "\r\n"), + BinContent = iolist_to_binary(Content), + ServerFun = fun (Socket) -> + case gen_tcp:send(Socket, BinContent) of + ok -> + exit(normal) + end + end, + ClientFun = fun (Socket) -> + Req = fake_request(Socket, ContentType, + size(BinContent)), + Res = parse_form(Req, fun handler_test/2), + [{"submit-name", "Larry"}, + {"files", {"file1.txt", {"text/plain",[]}, + <<"... contents of file1.txt ...">>} + }] = Res, + ok + end, + ok = with_socket_server(ServerFun, ClientFun), + ok. + +test_parse() -> + ContentType = "multipart/form-data; boundary=AaB03x", + "AaB03x" = get_boundary(ContentType), + Content = mochiweb_util:join( + ["--AaB03x", + "Content-Disposition: form-data; name=\"submit-name\"", + "", + "Larry", + "--AaB03x", + "Content-Disposition: form-data; name=\"files\";" + ++ "filename=\"file1.txt\"", + "Content-Type: text/plain", + "", + "... contents of file1.txt ...", + "--AaB03x--", + ""], "\r\n"), + BinContent = iolist_to_binary(Content), + Expect = [{headers, + [{"content-disposition", + {"form-data", [{"name", "submit-name"}]}}]}, + {body, <<"Larry">>}, + body_end, + {headers, + [{"content-disposition", + {"form-data", [{"name", "files"}, {"filename", "file1.txt"}]}}, + {"content-type", {"text/plain", []}}]}, + {body, <<"... contents of file1.txt ...">>}, + body_end, + eof], + TestCallback = fun (Next) -> test_callback(Next, Expect) end, + ServerFun = fun (Socket) -> + case gen_tcp:send(Socket, BinContent) of + ok -> + exit(normal) + end + end, + ClientFun = fun (Socket) -> + Req = fake_request(Socket, ContentType, + size(BinContent)), + Res = parse_multipart_request(Req, TestCallback), + {0, <<>>, ok} = Res, + ok + end, + ok = with_socket_server(ServerFun, ClientFun), + ok. + +test_find_boundary() -> + B = <<"\r\n--X">>, + {next_boundary, 0, 7} = find_boundary(B, <<"\r\n--X\r\nRest">>), + {next_boundary, 1, 7} = find_boundary(B, <<"!\r\n--X\r\nRest">>), + {end_boundary, 0, 9} = find_boundary(B, <<"\r\n--X--\r\nRest">>), + {end_boundary, 1, 9} = find_boundary(B, <<"!\r\n--X--\r\nRest">>), + not_found = find_boundary(B, <<"--X\r\nRest">>), + {maybe, 0} = find_boundary(B, <<"\r\n--X\r">>), + {maybe, 1} = find_boundary(B, <<"!\r\n--X\r">>), + P = <<"\r\n-----------------------------16037454351082272548568224146">>, + B0 = <<55,212,131,77,206,23,216,198,35,87,252,118,252,8,25,211,132,229, + 182,42,29,188,62,175,247,243,4,4,0,59, 13,10,45,45,45,45,45,45,45, + 45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45, + 49,54,48,51,55,52,53,52,51,53,49>>, + {maybe, 30} = find_boundary(P, B0), + ok. + +test_find_in_binary() -> + {exact, 0} = find_in_binary(<<"foo">>, <<"foobarbaz">>), + {exact, 1} = find_in_binary(<<"oo">>, <<"foobarbaz">>), + {exact, 8} = find_in_binary(<<"z">>, <<"foobarbaz">>), + not_found = find_in_binary(<<"q">>, <<"foobarbaz">>), + {partial, 7, 2} = find_in_binary(<<"azul">>, <<"foobarbaz">>), + {exact, 0} = find_in_binary(<<"foobarbaz">>, <<"foobarbaz">>), + {partial, 0, 3} = find_in_binary(<<"foobar">>, <<"foo">>), + {partial, 1, 3} = find_in_binary(<<"foobar">>, <<"afoo">>), + ok. + +test() -> + test_find_in_binary(), + test_find_boundary(), + test_parse(), + test_parse2(), + test_parse3(), + test_parse_form(), + ok. diff --git a/src/mochiweb/mochiweb_request.erl b/src/mochiweb/mochiweb_request.erl new file mode 100644 index 00000000..fd15cea9 --- /dev/null +++ b/src/mochiweb/mochiweb_request.erl @@ -0,0 +1,700 @@ +%% @author Bob Ippolito <bob@mochimedia.com> +%% @copyright 2007 Mochi Media, Inc. + +%% @doc MochiWeb HTTP Request abstraction. + +-module(mochiweb_request, [Socket, Method, RawPath, Version, Headers]). +-author('bob@mochimedia.com'). + +-include_lib("kernel/include/file.hrl"). + +-define(QUIP, "Any of you quaids got a smint?"). +-define(READ_SIZE, 8192). + +-export([get_header_value/1, get_primary_header_value/1, get/1, dump/0]). +-export([send/1, recv/1, recv/2, recv_body/0, recv_body/1]). +-export([start_response/1, start_response_length/1, start_raw_response/1]). +-export([respond/1, ok/1]). +-export([not_found/0]). +-export([parse_post/0, parse_qs/0]). +-export([should_close/0, cleanup/0]). +-export([parse_cookie/0, get_cookie_value/1]). +-export([serve_file/2]). +-export([test/0]). + +-define(SAVE_QS, mochiweb_request_qs). +-define(SAVE_PATH, mochiweb_request_path). +-define(SAVE_RECV, mochiweb_request_recv). +-define(SAVE_BODY, mochiweb_request_body). +-define(SAVE_BODY_LENGTH, mochiweb_request_body_length). +-define(SAVE_POST, mochiweb_request_post). +-define(SAVE_COOKIE, mochiweb_request_cookie). + +%% @type iolist() = [iolist() | binary() | char()]. +%% @type iodata() = binary() | iolist(). +%% @type key() = atom() | string() | binary() +%% @type value() = atom() | string() | binary() | integer() +%% @type headers(). A mochiweb_headers structure. +%% @type response(). A mochiweb_response parameterized module instance. +%% @type ioheaders() = headers() | [{key(), value()}]. + +% 10 second default idle timeout +-define(IDLE_TIMEOUT, 10000). + +% Maximum recv_body() length of 1MB +-define(MAX_RECV_BODY, (1024*1024)). + +%% @spec get_header_value(K) -> undefined | Value +%% @doc Get the value of a given request header. +get_header_value(K) -> + mochiweb_headers:get_value(K, Headers). + +get_primary_header_value(K) -> + mochiweb_headers:get_primary_value(K, Headers). + +%% @type field() = socket | method | raw_path | version | headers | peer | path | body_length | range + +%% @spec get(field()) -> term() +%% @doc Return the internal representation of the given field. +get(socket) -> + Socket; +get(method) -> + Method; +get(raw_path) -> + RawPath; +get(version) -> + Version; +get(headers) -> + Headers; +get(peer) -> + case inet:peername(Socket) of + {ok, {Addr={10, _, _, _}, _Port}} -> + case get_header_value("x-forwarded-for") of + undefined -> + inet_parse:ntoa(Addr); + Hosts -> + string:strip(lists:last(string:tokens(Hosts, ","))) + end; + {ok, {{127, 0, 0, 1}, _Port}} -> + case get_header_value("x-forwarded-for") of + undefined -> + "127.0.0.1"; + Hosts -> + string:strip(lists:last(string:tokens(Hosts, ","))) + end; + {ok, {Addr, _Port}} -> + inet_parse:ntoa(Addr) + end; +get(path) -> + case erlang:get(?SAVE_PATH) of + undefined -> + {Path0, _, _} = mochiweb_util:urlsplit_path(RawPath), + Path = mochiweb_util:unquote(Path0), + put(?SAVE_PATH, Path), + Path; + Cached -> + Cached + end; +get(body_length) -> + erlang:get(?SAVE_BODY_LENGTH); +get(range) -> + case get_header_value(range) of + undefined -> + undefined; + RawRange -> + parse_range_request(RawRange) + end. + +%% @spec dump() -> {mochiweb_request, [{atom(), term()}]} +%% @doc Dump the internal representation to a "human readable" set of terms +%% for debugging/inspection purposes. +dump() -> + {?MODULE, [{method, Method}, + {version, Version}, + {raw_path, RawPath}, + {headers, mochiweb_headers:to_list(Headers)}]}. + +%% @spec send(iodata()) -> ok +%% @doc Send data over the socket. +send(Data) -> + case gen_tcp:send(Socket, Data) of + ok -> + ok; + _ -> + exit(normal) + end. + +%% @spec recv(integer()) -> binary() +%% @doc Receive Length bytes from the client as a binary, with the default +%% idle timeout. +recv(Length) -> + recv(Length, ?IDLE_TIMEOUT). + +%% @spec recv(integer(), integer()) -> binary() +%% @doc Receive Length bytes from the client as a binary, with the given +%% Timeout in msec. +recv(Length, Timeout) -> + case gen_tcp:recv(Socket, Length, Timeout) of + {ok, Data} -> + put(?SAVE_RECV, true), + Data; + _ -> + exit(normal) + end. + +%% @spec body_length() -> undefined | chunked | unknown_transfer_encoding | integer() +%% @doc Infer body length from transfer-encoding and content-length headers. +body_length() -> + case get_header_value("transfer-encoding") of + undefined -> + case get_header_value("content-length") of + undefined -> + undefined; + Length -> + list_to_integer(Length) + end; + "chunked" -> + chunked; + Unknown -> + {unknown_transfer_encoding, Unknown} + end. + + +%% @spec recv_body() -> binary() +%% @doc Receive the body of the HTTP request (defined by Content-Length). +%% Will only receive up to the default max-body length of 1MB. +recv_body() -> + recv_body(?MAX_RECV_BODY). + +%% @spec recv_body(integer()) -> binary() +%% @doc Receive the body of the HTTP request (defined by Content-Length). +%% Will receive up to MaxBody bytes. +recv_body(MaxBody) -> + case get_header_value("expect") of + "100-continue" -> + start_raw_response({100, gb_trees:empty()}); + _Else -> + ok + end, + Body = case body_length() of + undefined -> + undefined; + {unknown_transfer_encoding, Unknown} -> + exit({unknown_transfer_encoding, Unknown}); + chunked -> + read_chunked_body(MaxBody, []); + 0 -> + <<>>; + Length when is_integer(Length), Length =< MaxBody -> + recv(Length); + Length -> + exit({body_too_large, Length}) + end, + put(?SAVE_BODY, Body), + Body. + + +%% @spec start_response({integer(), ioheaders()}) -> response() +%% @doc Start the HTTP response by sending the Code HTTP response and +%% ResponseHeaders. The server will set header defaults such as Server +%% and Date if not present in ResponseHeaders. +start_response({Code, ResponseHeaders}) -> + HResponse = mochiweb_headers:make(ResponseHeaders), + HResponse1 = mochiweb_headers:default_from_list(server_headers(), + HResponse), + start_raw_response({Code, HResponse1}). + +%% @spec start_raw_response({integer(), headers()}) -> response() +%% @doc Start the HTTP response by sending the Code HTTP response and +%% ResponseHeaders. +start_raw_response({Code, ResponseHeaders}) -> + F = fun ({K, V}, Acc) -> + [make_io(K), <<": ">>, V, <<"\r\n">> | Acc] + end, + End = lists:foldl(F, [<<"\r\n">>], + mochiweb_headers:to_list(ResponseHeaders)), + send([make_version(Version), make_code(Code), <<"\r\n">> | End]), + mochiweb:new_response({THIS, Code, ResponseHeaders}). + + +%% @spec start_response_length({integer(), ioheaders(), integer()}) -> response() +%% @doc Start the HTTP response by sending the Code HTTP response and +%% ResponseHeaders including a Content-Length of Length. The server +%% will set header defaults such as Server +%% and Date if not present in ResponseHeaders. +start_response_length({Code, ResponseHeaders, Length}) -> + HResponse = mochiweb_headers:make(ResponseHeaders), + HResponse1 = mochiweb_headers:enter("Content-Length", Length, HResponse), + start_response({Code, HResponse1}). + +%% @spec respond({integer(), ioheaders(), iodata() | chunked | {file, IoDevice}}) -> response() +%% @doc Start the HTTP response with start_response, and send Body to the +%% client (if the get(method) /= 'HEAD'). The Content-Length header +%% will be set by the Body length, and the server will insert header +%% defaults. +respond({Code, ResponseHeaders, {file, IoDevice}}) -> + Length = iodevice_size(IoDevice), + Response = start_response_length({Code, ResponseHeaders, Length}), + case Method of + 'HEAD' -> + ok; + _ -> + iodevice_stream(IoDevice) + end, + Response; +respond({Code, ResponseHeaders, chunked}) -> + HResponse = mochiweb_headers:make(ResponseHeaders), + HResponse1 = case Method of + 'HEAD' -> + %% This is what Google does, http://www.google.com/ + %% is chunked but HEAD gets Content-Length: 0. + %% The RFC is ambiguous so emulating Google is smart. + mochiweb_headers:enter("Content-Length", "0", + HResponse); + _ -> + mochiweb_headers:enter("Transfer-Encoding", "chunked", + HResponse) + end, + start_response({Code, HResponse1}); +respond({Code, ResponseHeaders, Body}) -> + Response = start_response_length({Code, ResponseHeaders, iolist_size(Body)}), + case Method of + 'HEAD' -> + ok; + _ -> + send(Body) + end, + Response. + +%% @spec not_found() -> response() +%% @doc respond({404, [{"Content-Type", "text/plain"}], "Not found."}). +not_found() -> + respond({404, [{"Content-Type", "text/plain"}], <<"Not found.">>}). + +%% @spec ok({value(), iodata()} | {value(), ioheaders(), iodata() | {file, IoDevice}}) -> +%% response() +%% @doc respond({200, [{"Content-Type", ContentType} | Headers], Body}). +ok({ContentType, Body}) -> + ok({ContentType, [], Body}); +ok({ContentType, ResponseHeaders, Body}) -> + HResponse = mochiweb_headers:make(ResponseHeaders), + case THIS:get(range) of + X when X =:= undefined; X =:= fail -> + HResponse1 = mochiweb_headers:enter("Content-Type", ContentType, HResponse), + respond({200, HResponse1, Body}); + Ranges -> + {PartList, Size} = range_parts(Body, Ranges), + case PartList of + [] -> %% no valid ranges + HResponse1 = mochiweb_headers:enter("Content-Type", + ContentType, + HResponse), + %% could be 416, for now we'll just return 200 + respond({200, HResponse1, Body}); + PartList -> + {RangeHeaders, RangeBody} = + parts_to_body(PartList, ContentType, Size), + HResponse1 = mochiweb_headers:enter_from_list( + [{"Accept-Ranges", "bytes"} | + RangeHeaders], + HResponse), + respond({206, HResponse1, RangeBody}) + end + end. + +%% @spec should_close() -> bool() +%% @doc Return true if the connection must be closed. If false, using +%% Keep-Alive should be safe. +should_close() -> + DidNotRecv = erlang:get(mochiweb_request_recv) =:= undefined, + Version < {1, 0} + % Connection: close + orelse get_header_value("connection") =:= "close" + % HTTP 1.0 requires Connection: Keep-Alive + orelse (Version =:= {1, 0} + andalso get_header_value("connection") /= "Keep-Alive") + % unread data left on the socket, can't safely continue + orelse (DidNotRecv + andalso get_header_value("content-length") /= undefined). + +%% @spec cleanup() -> ok +%% @doc Clean up any junk in the process dictionary, required before continuing +%% a Keep-Alive request. +cleanup() -> + [erase(K) || K <- [?SAVE_QS, + ?SAVE_PATH, + ?SAVE_RECV, + ?SAVE_BODY, + ?SAVE_POST, + ?SAVE_COOKIE]], + ok. + +%% @spec parse_qs() -> [{Key::string(), Value::string()}] +%% @doc Parse the query string of the URL. +parse_qs() -> + case erlang:get(?SAVE_QS) of + undefined -> + {_, QueryString, _} = mochiweb_util:urlsplit_path(RawPath), + Parsed = mochiweb_util:parse_qs(QueryString), + put(?SAVE_QS, Parsed), + Parsed; + Cached -> + Cached + end. + +%% @spec get_cookie_value(Key::string) -> string() | undefined +%% @doc Get the value of the given cookie. +get_cookie_value(Key) -> + proplists:get_value(Key, parse_cookie()). + +%% @spec parse_cookie() -> [{Key::string(), Value::string()}] +%% @doc Parse the cookie header. +parse_cookie() -> + case erlang:get(?SAVE_COOKIE) of + undefined -> + Cookies = case get_header_value("cookie") of + undefined -> + []; + Value -> + mochiweb_cookies:parse_cookie(Value) + end, + put(?SAVE_COOKIE, Cookies), + Cookies; + Cached -> + Cached + end. + +%% @spec parse_post() -> [{Key::string(), Value::string()}] +%% @doc Parse an application/x-www-form-urlencoded form POST. This +%% has the side-effect of calling recv_body(). +parse_post() -> + case erlang:get(?SAVE_POST) of + undefined -> + Parsed = case recv_body() of + undefined -> + []; + Binary -> + case get_primary_header_value("content-type") of + "application/x-www-form-urlencoded" -> + mochiweb_util:parse_qs(Binary); + _ -> + [] + end + end, + put(?SAVE_POST, Parsed), + Parsed; + Cached -> + Cached + end. + +read_chunked_body(Max, Acc) -> + case read_chunk_length() of + 0 -> + read_chunk(0), + iolist_to_binary(lists:reverse(Acc)); + Length when Length > Max -> + exit({body_too_large, chunked}); + Length -> + read_chunked_body(Max - Length, [read_chunk(Length) | Acc]) + end. + +%% @spec read_chunk_length() -> integer() +%% @doc Read the length of the next HTTP chunk. +read_chunk_length() -> + inet:setopts(Socket, [{packet, line}]), + case gen_tcp:recv(Socket, 0, ?IDLE_TIMEOUT) of + {ok, Header} -> + inet:setopts(Socket, [{packet, raw}]), + Splitter = fun (C) -> + C =/= $\r andalso C =/= $\n andalso C =/= $ + end, + {Hex, _Rest} = lists:splitwith(Splitter, binary_to_list(Header)), + mochihex:to_int(Hex); + _ -> + exit(normal) + end. + +%% @spec read_chunk(integer()) -> Chunk::binary() | [Footer::binary()] +%% @doc Read in a HTTP chunk of the given length. If Length is 0, then read the +%% HTTP footers (as a list of binaries, since they're nominal). +read_chunk(0) -> + inet:setopts(Socket, [{packet, line}]), + F = fun (F1, Acc) -> + case gen_tcp:recv(Socket, 0, ?IDLE_TIMEOUT) of + {ok, <<"\r\n">>} -> + Acc; + {ok, Footer} -> + F1(F1, [Footer | Acc]); + _ -> + exit(normal) + end + end, + Footers = F(F, []), + inet:setopts(Socket, [{packet, raw}]), + Footers; +read_chunk(Length) -> + case gen_tcp:recv(Socket, 2 + Length, ?IDLE_TIMEOUT) of + {ok, <<Chunk:Length/binary, "\r\n">>} -> + Chunk; + _ -> + exit(normal) + end. + +%% @spec serve_file(Path, DocRoot) -> Response +%% @doc Serve a file relative to DocRoot. +serve_file(Path, DocRoot) -> + FullPath = filename:join([DocRoot, Path]), + File = case filelib:is_dir(FullPath) of + true -> + filename:join([FullPath, "index.html"]); + false -> + FullPath + end, + case lists:prefix(DocRoot, File) of + true -> + case file:open(File, [raw, binary]) of + {ok, IoDevice} -> + ContentType = mochiweb_util:guess_mime(File), + Res = ok({ContentType, {file, IoDevice}}), + file:close(IoDevice), + Res; + _ -> + not_found() + end; + false -> + not_found() + end. + + +%% Internal API + +server_headers() -> + [{"Server", "MochiWeb/1.0 (" ++ ?QUIP ++ ")"}, + {"Date", httpd_util:rfc1123_date()}]. + +make_io(Atom) when is_atom(Atom) -> + atom_to_list(Atom); +make_io(Integer) when is_integer(Integer) -> + integer_to_list(Integer); +make_io(Io) when is_list(Io); is_binary(Io) -> + Io. + +make_code(X) when is_integer(X) -> + [integer_to_list(X), [" " | httpd_util:reason_phrase(X)]]; +make_code(Io) when is_list(Io); is_binary(Io) -> + Io. + +make_version({1, 0}) -> + <<"HTTP/1.0 ">>; +make_version(_) -> + <<"HTTP/1.1 ">>. + +iodevice_stream(IoDevice) -> + case file:read(IoDevice, ?READ_SIZE) of + eof -> + ok; + {ok, Data} -> + ok = send(Data), + iodevice_stream(IoDevice) + end. + + +parts_to_body([{Start, End, Body}], ContentType, Size) -> + %% return body for a range reponse with a single body + HeaderList = [{"Content-Type", ContentType}, + {"Content-Range", + ["bytes ", + make_io(Start), "-", make_io(End), + "/", make_io(Size)]}], + {HeaderList, Body}; +parts_to_body(BodyList, ContentType, Size) when is_list(BodyList) -> + %% return + %% header Content-Type: multipart/byteranges; boundary=441934886133bdee4 + %% and multipart body + Boundary = mochihex:to_hex(crypto:rand_bytes(8)), + HeaderList = [{"Content-Type", + ["multipart/byteranges; ", + "boundary=", Boundary]}], + MultiPartBody = multipart_body(BodyList, ContentType, Boundary, Size), + + {HeaderList, MultiPartBody}. + +multipart_body([], _ContentType, Boundary, _Size) -> + ["--", Boundary, "--\r\n"]; +multipart_body([{Start, End, Body} | BodyList], ContentType, Boundary, Size) -> + ["--", Boundary, "\r\n", + "Content-Type: ", ContentType, "\r\n", + "Content-Range: ", + "bytes ", make_io(Start), "-", make_io(End), + "/", make_io(Size), "\r\n\r\n", + Body, "\r\n" + | multipart_body(BodyList, ContentType, Boundary, Size)]. + +iodevice_size(IoDevice) -> + {ok, Size} = file:position(IoDevice, eof), + {ok, 0} = file:position(IoDevice, bof), + Size. + +range_parts({file, IoDevice}, Ranges) -> + Size = iodevice_size(IoDevice), + F = fun (Spec, Acc) -> + case range_skip_length(Spec, Size) of + invalid_range -> + Acc; + V -> + [V | Acc] + end + end, + LocNums = lists:foldr(F, [], Ranges), + {ok, Data} = file:pread(IoDevice, LocNums), + Bodies = lists:zipwith(fun ({Skip, Length}, PartialBody) -> + {Skip, Skip + Length - 1, PartialBody} + end, + LocNums, Data), + {Bodies, Size}; + +range_parts(Body0, Ranges) -> + Body = iolist_to_binary(Body0), + Size = size(Body), + F = fun(Spec, Acc) -> + case range_skip_length(Spec, Size) of + invalid_range -> + Acc; + {Skip, Length} -> + <<_:Skip/binary, PartialBody:Length/binary, _/binary>> = Body, + [{Skip, Skip + Length - 1, PartialBody} | Acc] + end + end, + {lists:foldr(F, [], Ranges), Size}. + +range_skip_length(Spec, Size) -> + case Spec of + {none, R} when R =< Size, R >= 0 -> + {Size - R, R}; + {none, _OutOfRange} -> + {0, Size}; + {R, none} when R >= 0, R < Size -> + {R, Size - R}; + {_OutOfRange, none} -> + invalid_range; + {Start, End} when 0 =< Start, Start =< End, End < Size -> + {Start, End - Start + 1}; + {_OutOfRange, _End} -> + invalid_range + end. + +parse_range_request(RawRange) when is_list(RawRange) -> + try + "bytes=" ++ RangeString = RawRange, + Ranges = string:tokens(RangeString, ","), + lists:map(fun ("-" ++ V) -> + {none, list_to_integer(V)}; + (R) -> + case string:tokens(R, "-") of + [S1, S2] -> + {list_to_integer(S1), list_to_integer(S2)}; + [S] -> + {list_to_integer(S), none} + end + end, + Ranges) + catch + _:_ -> + fail + end. + + +test() -> + ok = test_range(), + ok. + +test_range() -> + %% valid, single ranges + io:format("Testing parse_range_request with valid single ranges~n"), + io:format("1"), + [{20, 30}] = parse_range_request("bytes=20-30"), + io:format("2"), + [{20, none}] = parse_range_request("bytes=20-"), + io:format("3"), + [{none, 20}] = parse_range_request("bytes=-20"), + io:format(".. ok ~n"), + + + %% invalid, single ranges + io:format("Testing parse_range_request with invalid ranges~n"), + io:format("1"), + fail = parse_range_request(""), + io:format("2"), + fail = parse_range_request("garbage"), + io:format("3"), + fail = parse_range_request("bytes=-20-30"), + io:format(".. ok ~n"), + + %% valid, multiple range + io:format("Testing parse_range_request with valid multiple ranges~n"), + io:format("1"), + [{20, 30}, {50, 100}, {110, 200}] = + parse_range_request("bytes=20-30,50-100,110-200"), + io:format("2"), + [{20, none}, {50, 100}, {none, 200}] = + parse_range_request("bytes=20-,50-100,-200"), + io:format(".. ok~n"), + + %% no ranges + io:format("Testing out parse_range_request with no ranges~n"), + io:format("1"), + [] = parse_range_request("bytes="), + io:format(".. ok~n"), + + Body = <<"012345678901234567890123456789012345678901234567890123456789">>, + BodySize = size(Body), %% 60 + BodySize = 60, + + %% these values assume BodySize =:= 60 + io:format("Testing out range_skip_length on valid ranges~n"), + io:format("1"), + {1,9} = range_skip_length({1,9}, BodySize), %% 1-9 + io:format("2"), + {10,10} = range_skip_length({10,19}, BodySize), %% 10-19 + io:format("3"), + {40, 20} = range_skip_length({none, 20}, BodySize), %% -20 + io:format("4"), + {30, 30} = range_skip_length({30, none}, BodySize), %% 30- + io:format(".. ok ~n"), + + %% valid edge cases for range_skip_length + io:format("Testing out range_skip_length on valid edge case ranges~n"), + io:format("1"), + {BodySize, 0} = range_skip_length({none, 0}, BodySize), + io:format("2"), + {0, BodySize} = range_skip_length({none, BodySize}, BodySize), + io:format("3"), + {0, BodySize} = range_skip_length({0, none}, BodySize), + BodySizeLess1 = BodySize - 1, + io:format("4"), + {BodySizeLess1, 1} = range_skip_length({BodySize - 1, none}, BodySize), + + %% out of range, return whole thing + io:format("5"), + {0, BodySize} = range_skip_length({none, BodySize + 1}, BodySize), + io:format("6"), + {0, BodySize} = range_skip_length({none, -1}, BodySize), + io:format(".. ok ~n"), + + %% invalid ranges + io:format("Testing out range_skip_length on invalid ranges~n"), + io:format("1"), + invalid_range = range_skip_length({-1, 30}, BodySize), + io:format("2"), + invalid_range = range_skip_length({0, BodySize + 1}, BodySize), + io:format("3"), + invalid_range = range_skip_length({-1, BodySize + 1}, BodySize), + io:format("4"), + invalid_range = range_skip_length({BodySize, 40}, BodySize), + io:format("5"), + invalid_range = range_skip_length({-1, none}, BodySize), + io:format("6"), + invalid_range = range_skip_length({BodySize, none}, BodySize), + io:format(".. ok ~n"), + ok. + diff --git a/src/mochiweb/mochiweb_response.erl b/src/mochiweb/mochiweb_response.erl new file mode 100644 index 00000000..87917c40 --- /dev/null +++ b/src/mochiweb/mochiweb_response.erl @@ -0,0 +1,52 @@ +%% @author Bob Ippolito <bob@mochimedia.com> +%% @copyright 2007 Mochi Media, Inc. + +%% @doc Response abstraction. + +-module(mochiweb_response, [Request, Code, Headers]). +-author('bob@mochimedia.com'). + +-define(QUIP, "Any of you quaids got a smint?"). + +-export([get_header_value/1, get/1, dump/0]). +-export([send/1, write_chunk/1]). + +%% @spec get_header_value(string() | atom() | binary()) -> string() | undefined +%% @doc Get the value of the given response header. +get_header_value(K) -> + mochiweb_headers:get_value(K, Headers). + +%% @spec get(request | code | headers) -> term() +%% @doc Return the internal representation of the given field. +get(request) -> + Request; +get(code) -> + Code; +get(headers) -> + Headers. + +%% @spec dump() -> {mochiweb_request, [{atom(), term()}]} +%% @doc Dump the internal representation to a "human readable" set of terms +%% for debugging/inspection purposes. +dump() -> + [{request, Request:dump()}, + {code, Code}, + {headers, mochiweb_headers:to_list(Headers)}]. + +%% @spec send(iodata()) -> ok +%% @doc Send data over the socket if the method is not HEAD. +send(Data) -> + case Request:get(method) of + 'HEAD' -> + ok; + _ -> + Request:send(Data) + end. + +%% @spec write_chunk(iodata()) -> ok +%% @doc Write a chunk of a HTTP chunked response. If Data is zero length, +%% then the chunked response will be finished. +write_chunk(Data) -> + Length = iolist_size(Data), + send(io_lib:format("~.16b\r\n", [Length])), + send([Data, <<"\r\n">>]). diff --git a/src/mochiweb/mochiweb_skel.erl b/src/mochiweb/mochiweb_skel.erl new file mode 100644 index 00000000..a1c37f98 --- /dev/null +++ b/src/mochiweb/mochiweb_skel.erl @@ -0,0 +1,71 @@ +-module(mochiweb_skel). +-export([skelcopy/2]). + +-include_lib("kernel/include/file.hrl"). + +%% External API + +skelcopy(DestDir, Name) -> + ok = ensuredir(DestDir), + LDst = case length(filename:dirname(DestDir)) of + 1 -> %% handle case when dirname returns "/" + 0; + N -> + N + 1 + end, + skelcopy(src(), DestDir, Name, LDst), + ok = file:make_symlink( + filename:join(filename:dirname(code:which(?MODULE)), ".."), + filename:join([DestDir, Name, "deps", "mochiweb-src"])). + + +%% Internal API + +src() -> + Dir = filename:dirname(code:which(?MODULE)), + filename:join(Dir, "../priv/skel"). + +skel() -> + "skel". + +skelcopy(Src, DestDir, Name, LDst) -> + {ok, Dest, _} = regexp:gsub(filename:basename(Src), skel(), Name), + case file:read_file_info(Src) of + {ok, #file_info{type=directory, mode=Mode}} -> + Dir = DestDir ++ "/" ++ Dest, + EDst = lists:nthtail(LDst, Dir), + ok = ensuredir(Dir), + ok = file:write_file_info(Dir, #file_info{mode=Mode}), + {ok, Files} = file:list_dir(Src), + io:format("~s/~n", [EDst]), + lists:foreach(fun ("." ++ _) -> ok; + (F) -> + skelcopy(filename:join(Src, F), + Dir, + Name, + LDst) + end, + Files), + ok; + {ok, #file_info{type=regular, mode=Mode}} -> + OutFile = filename:join(DestDir, Dest), + {ok, B} = file:read_file(Src), + {ok, S, _} = regexp:gsub(binary_to_list(B), skel(), Name), + ok = file:write_file(OutFile, list_to_binary(S)), + ok = file:write_file_info(OutFile, #file_info{mode=Mode}), + io:format(" ~s~n", [filename:basename(Src)]), + ok; + {ok, _} -> + io:format("ignored source file: ~p~n", [Src]), + ok + end. + +ensuredir(Dir) -> + case file:make_dir(Dir) of + ok -> + ok; + {error, eexist} -> + ok; + E -> + E + end. diff --git a/src/mochiweb/mochiweb_socket_server.erl b/src/mochiweb/mochiweb_socket_server.erl new file mode 100644 index 00000000..764481c4 --- /dev/null +++ b/src/mochiweb/mochiweb_socket_server.erl @@ -0,0 +1,234 @@ +%% @author Bob Ippolito <bob@mochimedia.com> +%% @copyright 2007 Mochi Media, Inc. + +%% @doc MochiWeb socket server. + +-module(mochiweb_socket_server). +-author('bob@mochimedia.com'). +-behaviour(gen_server). + +-export([start/1, stop/1]). +-export([init/1, handle_call/3, handle_cast/2, terminate/2, code_change/3, + handle_info/2]). +-export([get/2]). + +-export([acceptor_loop/1]). + +-record(mochiweb_socket_server, + {port, + loop, + name=undefined, + max=2048, + ip=any, + listen=null, + acceptor=null, + backlog=30}). + +start(State=#mochiweb_socket_server{}) -> + start_server(State); +start(Options) -> + start(parse_options(Options)). + +get(Name, Property) -> + gen_server:call(Name, {get, Property}). + +stop(Name) when is_atom(Name) -> + gen_server:cast(Name, stop); +stop(Pid) when is_pid(Pid) -> + gen_server:cast(Pid, stop); +stop({local, Name}) -> + stop(Name); +stop({global, Name}) -> + stop(Name); +stop(Options) -> + State = parse_options(Options), + stop(State#mochiweb_socket_server.name). + +%% Internal API + +parse_options(Options) -> + parse_options(Options, #mochiweb_socket_server{}). + +parse_options([], State) -> + State; +parse_options([{name, L} | Rest], State) when is_list(L) -> + Name = {local, list_to_atom(L)}, + parse_options(Rest, State#mochiweb_socket_server{name=Name}); +parse_options([{name, A} | Rest], State) when is_atom(A) -> + Name = {local, A}, + parse_options(Rest, State#mochiweb_socket_server{name=Name}); +parse_options([{name, Name} | Rest], State) -> + parse_options(Rest, State#mochiweb_socket_server{name=Name}); +parse_options([{port, L} | Rest], State) when is_list(L) -> + Port = list_to_integer(L), + parse_options(Rest, State#mochiweb_socket_server{port=Port}); +parse_options([{port, Port} | Rest], State) -> + parse_options(Rest, State#mochiweb_socket_server{port=Port}); +parse_options([{ip, Ip} | Rest], State) -> + ParsedIp = case Ip of + any -> + any; + Ip when is_tuple(Ip) -> + Ip; + Ip when is_list(Ip) -> + {ok, IpTuple} = inet_parse:address(Ip), + IpTuple + end, + parse_options(Rest, State#mochiweb_socket_server{ip=ParsedIp}); +parse_options([{loop, Loop} | Rest], State) -> + parse_options(Rest, State#mochiweb_socket_server{loop=Loop}); +parse_options([{backlog, Backlog} | Rest], State) -> + parse_options(Rest, State#mochiweb_socket_server{backlog=Backlog}); +parse_options([{max, Max} | Rest], State) -> + MaxInt = case Max of + Max when is_list(Max) -> + list_to_integer(Max); + Max when is_integer(Max) -> + Max + end, + parse_options(Rest, State#mochiweb_socket_server{max=MaxInt}). + +start_server(State=#mochiweb_socket_server{name=Name}) -> + case Name of + undefined -> + gen_server:start_link(?MODULE, State, []); + _ -> + gen_server:start_link(Name, ?MODULE, State, []) + end. + +init(State=#mochiweb_socket_server{ip=Ip, port=Port, backlog=Backlog}) -> + process_flag(trap_exit, true), + BaseOpts = [binary, + {reuseaddr, true}, + {packet, 0}, + {backlog, Backlog}, + {recbuf, 8192}, + {active, false}], + Opts = case Ip of + any -> + BaseOpts; + Ip -> + [{ip, Ip} | BaseOpts] + end, + case gen_tcp_listen(Port, Opts, State) of + {stop, eacces} -> + case Port < 1024 of + true -> + case fdsrv:start() of + {ok, _} -> + case fdsrv:bind_socket(tcp, Port) of + {ok, Fd} -> + gen_tcp_listen(Port, [{fd, Fd} | Opts], State); + _ -> + {stop, fdsrv_bind_failed} + end; + _ -> + {stop, fdsrv_start_failed} + end; + false -> + {stop, eacces} + end; + Other -> + Other + end. + +gen_tcp_listen(Port, Opts, State) -> + case gen_tcp:listen(Port, Opts) of + {ok, Listen} -> + {ok, ListenPort} = inet:port(Listen), + {ok, new_acceptor(State#mochiweb_socket_server{listen=Listen, + port=ListenPort})}; + {error, Reason} -> + {stop, Reason} + end. + +new_acceptor(State=#mochiweb_socket_server{max=0}) -> + io:format("Not accepting new connections~n"), + State#mochiweb_socket_server{acceptor=null}; +new_acceptor(State=#mochiweb_socket_server{listen=Listen,loop=Loop}) -> + Pid = proc_lib:spawn_link(?MODULE, acceptor_loop, + [{self(), Listen, Loop}]), + State#mochiweb_socket_server{acceptor=Pid}. + +call_loop({M, F}, Socket) -> + M:F(Socket); +call_loop(Loop, Socket) -> + Loop(Socket). + +acceptor_loop({Server, Listen, Loop}) -> + case catch gen_tcp:accept(Listen) of + {ok, Socket} -> + gen_server:cast(Server, {accepted, self()}), + call_loop(Loop, Socket); + {error, closed} -> + exit({error, closed}); + Other -> + error_logger:error_report( + [{application, mochiweb}, + "Accept failed error", + lists:flatten(io_lib:format("~p", [Other]))]), + exit({error, accept_failed}) + end. + + +do_get(port, #mochiweb_socket_server{port=Port}) -> + Port. + +handle_call({get, Property}, _From, State) -> + Res = do_get(Property, State), + {reply, Res, State}; +handle_call(_Message, _From, State) -> + Res = error, + {reply, Res, State}. + +handle_cast({accepted, Pid}, + State=#mochiweb_socket_server{acceptor=Pid, max=Max}) -> + % io:format("accepted ~p~n", [Pid]), + State1 = State#mochiweb_socket_server{max=Max - 1}, + {noreply, new_acceptor(State1)}; +handle_cast(stop, State) -> + {stop, normal, State}. + +terminate(_Reason, #mochiweb_socket_server{listen=Listen, port=Port}) -> + gen_tcp:close(Listen), + case Port < 1024 of + true -> + catch fdsrv:stop(), + ok; + false -> + ok + end. + +code_change(_OldVsn, State, _Extra) -> + State. + +handle_info({'EXIT', Pid, normal}, + State=#mochiweb_socket_server{acceptor=Pid}) -> + % io:format("normal acceptor down~n"), + {noreply, new_acceptor(State)}; +handle_info({'EXIT', Pid, Reason}, + State=#mochiweb_socket_server{acceptor=Pid}) -> + error_logger:error_report({?MODULE, ?LINE, + {acceptor_error, Reason}}), + timer:sleep(100), + {noreply, new_acceptor(State)}; +handle_info({'EXIT', _LoopPid, Reason}, + State=#mochiweb_socket_server{acceptor=Pid, max=Max}) -> + case Reason of + normal -> + ok; + _ -> + error_logger:error_report({?MODULE, ?LINE, + {child_error, Reason}}) + end, + State1 = State#mochiweb_socket_server{max=Max + 1}, + State2 = case Pid of + null -> + new_acceptor(State1); + _ -> + State1 + end, + {noreply, State2}; +handle_info(Info, State) -> + error_logger:info_report([{'INFO', Info}, {'State', State}]), + {noreply, State}. diff --git a/src/mochiweb/mochiweb_sup.erl b/src/mochiweb/mochiweb_sup.erl new file mode 100644 index 00000000..5cb525b5 --- /dev/null +++ b/src/mochiweb/mochiweb_sup.erl @@ -0,0 +1,34 @@ +%% @author Bob Ippolito <bob@mochimedia.com> +%% @copyright 2007 Mochi Media, Inc. + +%% @doc Supervisor for the mochiweb application. + +-module(mochiweb_sup). +-author('bob@mochimedia.com'). + +-behaviour(supervisor). + +%% External exports +-export([start_link/0, upgrade/0]). + +%% supervisor callbacks +-export([init/1]). + +%% @spec start_link() -> ServerRet +%% @doc API for starting the supervisor. +start_link() -> + supervisor:start_link({local, ?MODULE}, ?MODULE, []). + +%% @spec upgrade() -> ok +%% @doc Add processes if necessary. +upgrade() -> + {ok, {_, Specs}} = init([]), + [supervisor:start_child(?MODULE, Spec) || Spec <- Specs], + ok. + +%% @spec init([]) -> SupervisorTree +%% @doc supervisor callback, ensures yaws is in embedded mode and then +%% returns the supervisor tree. +init([]) -> + Processes = [], + {ok, {{one_for_one, 10, 10}, Processes}}. diff --git a/src/mochiweb/mochiweb_util.erl b/src/mochiweb/mochiweb_util.erl new file mode 100644 index 00000000..a2b6b2fb --- /dev/null +++ b/src/mochiweb/mochiweb_util.erl @@ -0,0 +1,486 @@ +%% @author Bob Ippolito <bob@mochimedia.com> +%% @copyright 2007 Mochi Media, Inc. + +%% @doc Utilities for parsing and quoting. + +-module(mochiweb_util). +-author('bob@mochimedia.com'). +-export([join/2, quote_plus/1, urlencode/1, parse_qs/1, unquote/1]). +-export([path_split/1]). +-export([urlsplit/1, urlsplit_path/1, urlunsplit/1, urlunsplit_path/1]). +-export([guess_mime/1, parse_header/1]). +-export([shell_quote/1, cmd/1, cmd_string/1, cmd_port/2]). +-export([record_to_proplist/2, record_to_proplist/3]). +-export([test/0]). + +-define(PERCENT, 37). % $\% +-define(FULLSTOP, 46). % $\. +-define(IS_HEX(C), ((C >= $0 andalso C =< $9) orelse + (C >= $a andalso C =< $f) orelse + (C >= $A andalso C =< $F))). +-define(QS_SAFE(C), ((C >= $a andalso C =< $z) orelse + (C >= $A andalso C =< $Z) orelse + (C >= $0 andalso C =< $9) orelse + (C =:= ?FULLSTOP orelse C =:= $- orelse C =:= $~ orelse + C =:= $_))). + +hexdigit(C) when C < 10 -> $0 + C; +hexdigit(C) when C < 16 -> $A + (C - 10). + +unhexdigit(C) when C >= $0, C =< $9 -> C - $0; +unhexdigit(C) when C >= $a, C =< $f -> C - $a + 10; +unhexdigit(C) when C >= $A, C =< $F -> C - $A + 10. + +%% @spec shell_quote(string()) -> string() +%% @doc Quote a string according to UNIX shell quoting rules, returns a string +%% surrounded by double quotes. +shell_quote(L) -> + shell_quote(L, [$\"]). + +%% @spec cmd_port([string()], Options) -> port() +%% @doc open_port({spawn, mochiweb_util:cmd_string(Argv)}, Options). +cmd_port(Argv, Options) -> + open_port({spawn, cmd_string(Argv)}, Options). + +%% @spec cmd([string()]) -> string() +%% @doc os:cmd(cmd_string(Argv)). +cmd(Argv) -> + os:cmd(cmd_string(Argv)). + +%% @spec cmd_string([string()]) -> string() +%% @doc Create a shell quoted command string from a list of arguments. +cmd_string(Argv) -> + join([shell_quote(X) || X <- Argv], " "). + +%% @spec join([string()], Separator) -> string() +%% @doc Join a list of strings together with the given separator +%% string or char. +join([], _Separator) -> + []; +join([S], _Separator) -> + lists:flatten(S); +join(Strings, Separator) -> + lists:flatten(revjoin(lists:reverse(Strings), Separator, [])). + +revjoin([], _Separator, Acc) -> + Acc; +revjoin([S | Rest], Separator, []) -> + revjoin(Rest, Separator, [S]); +revjoin([S | Rest], Separator, Acc) -> + revjoin(Rest, Separator, [S, Separator | Acc]). + +%% @spec quote_plus(atom() | integer() | string()) -> string() +%% @doc URL safe encoding of the given term. +quote_plus(Atom) when is_atom(Atom) -> + quote_plus(atom_to_list(Atom)); +quote_plus(Int) when is_integer(Int) -> + quote_plus(integer_to_list(Int)); +quote_plus(String) -> + quote_plus(String, []). + +quote_plus([], Acc) -> + lists:reverse(Acc); +quote_plus([C | Rest], Acc) when ?QS_SAFE(C) -> + quote_plus(Rest, [C | Acc]); +quote_plus([$\s | Rest], Acc) -> + quote_plus(Rest, [$+ | Acc]); +quote_plus([C | Rest], Acc) -> + <<Hi:4, Lo:4>> = <<C>>, + quote_plus(Rest, [hexdigit(Lo), hexdigit(Hi), ?PERCENT | Acc]). + +%% @spec urlencode([{Key, Value}]) -> string() +%% @doc URL encode the property list. +urlencode(Props) -> + RevPairs = lists:foldl(fun ({K, V}, Acc) -> + [[quote_plus(K), $=, quote_plus(V)] | Acc] + end, [], Props), + lists:flatten(revjoin(RevPairs, $&, [])). + +%% @spec parse_qs(string() | binary()) -> [{Key, Value}] +%% @doc Parse a query string or application/x-www-form-urlencoded. +parse_qs(Binary) when is_binary(Binary) -> + parse_qs(binary_to_list(Binary)); +parse_qs(String) -> + parse_qs(String, []). + +parse_qs([], Acc) -> + lists:reverse(Acc); +parse_qs(String, Acc) -> + {Key, Rest} = parse_qs_key(String), + {Value, Rest1} = parse_qs_value(Rest), + parse_qs(Rest1, [{Key, Value} | Acc]). + +parse_qs_key(String) -> + parse_qs_key(String, []). + +parse_qs_key([], Acc) -> + {qs_revdecode(Acc), ""}; +parse_qs_key([$= | Rest], Acc) -> + {qs_revdecode(Acc), Rest}; +parse_qs_key(Rest=[$; | _], Acc) -> + {qs_revdecode(Acc), Rest}; +parse_qs_key(Rest=[$& | _], Acc) -> + {qs_revdecode(Acc), Rest}; +parse_qs_key([C | Rest], Acc) -> + parse_qs_key(Rest, [C | Acc]). + +parse_qs_value(String) -> + parse_qs_value(String, []). + +parse_qs_value([], Acc) -> + {qs_revdecode(Acc), ""}; +parse_qs_value([$; | Rest], Acc) -> + {qs_revdecode(Acc), Rest}; +parse_qs_value([$& | Rest], Acc) -> + {qs_revdecode(Acc), Rest}; +parse_qs_value([C | Rest], Acc) -> + parse_qs_value(Rest, [C | Acc]). + +%% @spec unquote(string() | binary()) -> string() +%% @doc Unquote a URL encoded string. +unquote(Binary) when is_binary(Binary) -> + unquote(binary_to_list(Binary)); +unquote(String) -> + qs_revdecode(lists:reverse(String)). + +qs_revdecode(S) -> + qs_revdecode(S, []). + +qs_revdecode([], Acc) -> + Acc; +qs_revdecode([$+ | Rest], Acc) -> + qs_revdecode(Rest, [$\s | Acc]); +qs_revdecode([Lo, Hi, ?PERCENT | Rest], Acc) when ?IS_HEX(Lo), ?IS_HEX(Hi) -> + qs_revdecode(Rest, [(unhexdigit(Lo) bor (unhexdigit(Hi) bsl 4)) | Acc]); +qs_revdecode([C | Rest], Acc) -> + qs_revdecode(Rest, [C | Acc]). + +%% @spec urlsplit(Url) -> {Scheme, Netloc, Path, Query, Fragment} +%% @doc Return a 5-tuple, does not expand % escapes. Only supports HTTP style +%% URLs. +urlsplit(Url) -> + {Scheme, Url1} = urlsplit_scheme(Url), + {Netloc, Url2} = urlsplit_netloc(Url1), + {Path, Query, Fragment} = urlsplit_path(Url2), + {Scheme, Netloc, Path, Query, Fragment}. + +urlsplit_scheme(Url) -> + urlsplit_scheme(Url, []). + +urlsplit_scheme([], Acc) -> + {"", lists:reverse(Acc)}; +urlsplit_scheme(":" ++ Rest, Acc) -> + {string:to_lower(lists:reverse(Acc)), Rest}; +urlsplit_scheme([C | Rest], Acc) -> + urlsplit_scheme(Rest, [C | Acc]). + +urlsplit_netloc("//" ++ Rest) -> + urlsplit_netloc(Rest, []); +urlsplit_netloc(Path) -> + {"", Path}. + +urlsplit_netloc(Rest=[C | _], Acc) when C =:= $/; C =:= $?; C =:= $# -> + {lists:reverse(Acc), Rest}; +urlsplit_netloc([C | Rest], Acc) -> + urlsplit_netloc(Rest, [C | Acc]). + + +%% @spec path_split(string()) -> {Part, Rest} +%% @doc Split a path starting from the left, as in URL traversal. +%% path_split("foo/bar") = {"foo", "bar"}, +%% path_split("/foo/bar") = {"", "foo/bar"}. +path_split(S) -> + path_split(S, []). + +path_split("", Acc) -> + {lists:reverse(Acc), ""}; +path_split("/" ++ Rest, Acc) -> + {lists:reverse(Acc), Rest}; +path_split([C | Rest], Acc) -> + path_split(Rest, [C | Acc]). + + +%% @spec urlunsplit({Scheme, Netloc, Path, Query, Fragment}) -> string() +%% @doc Assemble a URL from the 5-tuple. Path must be absolute. +urlunsplit({Scheme, Netloc, Path, Query, Fragment}) -> + lists:flatten([case Scheme of "" -> ""; _ -> [Scheme, "://"] end, + Netloc, + urlunsplit_path({Path, Query, Fragment})]). + +%% @spec urlunsplit_path({Path, Query, Fragment}) -> string() +%% @doc Assemble a URL path from the 3-tuple. +urlunsplit_path({Path, Query, Fragment}) -> + lists:flatten([Path, + case Query of "" -> ""; _ -> [$? | Query] end, + case Fragment of "" -> ""; _ -> [$# | Fragment] end]). + +%% @spec urlsplit_path(Url) -> {Path, Query, Fragment} +%% @doc Return a 3-tuple, does not expand % escapes. Only supports HTTP style +%% paths. +urlsplit_path(Path) -> + urlsplit_path(Path, []). + +urlsplit_path("", Acc) -> + {lists:reverse(Acc), "", ""}; +urlsplit_path("?" ++ Rest, Acc) -> + {Query, Fragment} = urlsplit_query(Rest), + {lists:reverse(Acc), Query, Fragment}; +urlsplit_path("#" ++ Rest, Acc) -> + {lists:reverse(Acc), "", Rest}; +urlsplit_path([C | Rest], Acc) -> + urlsplit_path(Rest, [C | Acc]). + +urlsplit_query(Query) -> + urlsplit_query(Query, []). + +urlsplit_query("", Acc) -> + {lists:reverse(Acc), ""}; +urlsplit_query("#" ++ Rest, Acc) -> + {lists:reverse(Acc), Rest}; +urlsplit_query([C | Rest], Acc) -> + urlsplit_query(Rest, [C | Acc]). + +%% @spec guess_mime(string()) -> string() +%% @doc Guess the mime type of a file by the extension of its filename. +guess_mime(File) -> + case filename:extension(File) of + ".html" -> + "text/html"; + ".xhtml" -> + "application/xhtml+xml"; + ".xml" -> + "application/xml"; + ".css" -> + "text/css"; + ".js" -> + "application/x-javascript"; + ".jpg" -> + "image/jpeg"; + ".gif" -> + "image/gif"; + ".png" -> + "image/png"; + ".swf" -> + "application/x-shockwave-flash"; + ".zip" -> + "application/zip"; + ".bz2" -> + "application/x-bzip2"; + ".gz" -> + "application/x-gzip"; + ".tar" -> + "application/x-tar"; + ".tgz" -> + "application/x-gzip"; + ".txt" -> + "text/plain"; + ".doc" -> + "application/msword"; + ".pdf" -> + "application/pdf"; + ".xls" -> + "application/vnd.ms-excel"; + ".rtf" -> + "application/rtf"; + ".mov" -> + "video/quicktime"; + ".mp3" -> + "audio/mpeg"; + ".z" -> + "application/x-compress"; + ".wav" -> + "audio/x-wav"; + ".ico" -> + "image/x-icon"; + ".bmp" -> + "image/bmp"; + ".m4a" -> + "audio/mpeg"; + ".m3u" -> + "audio/x-mpegurl"; + ".exe" -> + "application/octet-stream"; + ".csv" -> + "text/csv"; + _ -> + "text/plain" + end. + +%% @spec parse_header(string()) -> {Type, [{K, V}]} +%% @doc Parse a Content-Type like header, return the main Content-Type +%% and a property list of options. +parse_header(String) -> + %% TODO: This is exactly as broken as Python's cgi module. + %% Should parse properly like mochiweb_cookies. + [Type | Parts] = [string:strip(S) || S <- string:tokens(String, ";")], + F = fun (S, Acc) -> + case lists:splitwith(fun (C) -> C =/= $= end, S) of + {"", _} -> + %% Skip anything with no name + Acc; + {_, ""} -> + %% Skip anything with no value + Acc; + {Name, [$\= | Value]} -> + [{string:to_lower(string:strip(Name)), + unquote_header(string:strip(Value))} | Acc] + end + end, + {string:to_lower(Type), + lists:foldr(F, [], Parts)}. + +unquote_header("\"" ++ Rest) -> + unquote_header(Rest, []); +unquote_header(S) -> + S. + +unquote_header("", Acc) -> + lists:reverse(Acc); +unquote_header("\"", Acc) -> + lists:reverse(Acc); +unquote_header([$\\, C | Rest], Acc) -> + unquote_header(Rest, [C | Acc]); +unquote_header([C | Rest], Acc) -> + unquote_header(Rest, [C | Acc]). + +%% @spec record_to_proplist(Record, Fields) -> proplist() +%% @doc calls record_to_proplist/3 with a default TypeKey of '__record' +record_to_proplist(Record, Fields) -> + record_to_proplist(Record, Fields, '__record'). + +%% @spec record_to_proplist(Record, Fields, TypeKey) -> proplist() +%% @doc Return a proplist of the given Record with each field in the +%% Fields list set as a key with the corresponding value in the Record. +%% TypeKey is the key that is used to store the record type +%% Fields should be obtained by calling record_info(fields, record_type) +%% where record_type is the record type of Record +record_to_proplist(Record, Fields, TypeKey) + when is_tuple(Record), + is_list(Fields), + size(Record) - 1 =:= length(Fields) -> + lists:zip([TypeKey | Fields], tuple_to_list(Record)). + + +shell_quote([], Acc) -> + lists:reverse([$\" | Acc]); +shell_quote([C | Rest], Acc) when C =:= $\" orelse C =:= $\` orelse + C =:= $\\ orelse C =:= $\$ -> + shell_quote(Rest, [C, $\\ | Acc]); +shell_quote([C | Rest], Acc) -> + shell_quote(Rest, [C | Acc]). + +test() -> + test_join(), + test_quote_plus(), + test_unquote(), + test_urlencode(), + test_parse_qs(), + test_urlsplit_path(), + test_urlunsplit_path(), + test_urlsplit(), + test_urlunsplit(), + test_path_split(), + test_guess_mime(), + test_parse_header(), + test_shell_quote(), + test_cmd(), + test_cmd_string(), + ok. + +test_shell_quote() -> + "\"foo \\$bar\\\"\\`' baz\"" = shell_quote("foo $bar\"`' baz"), + ok. + +test_cmd() -> + "$bling$ `word`!\n" = cmd(["echo", "$bling$ `word`!"]), + ok. + +test_cmd_string() -> + "\"echo\" \"\\$bling\\$ \\`word\\`!\"" = cmd_string(["echo", "$bling$ `word`!"]), + ok. + +test_parse_header() -> + {"multipart/form-data", [{"boundary", "AaB03x"}]} = + parse_header("multipart/form-data; boundary=AaB03x"), + ok. + +test_guess_mime() -> + "text/plain" = guess_mime(""), + "text/plain" = guess_mime(".text"), + "application/zip" = guess_mime(".zip"), + "application/zip" = guess_mime("x.zip"), + "text/html" = guess_mime("x.html"), + "application/xhtml+xml" = guess_mime("x.xhtml"), + ok. + +test_path_split() -> + {"", "foo/bar"} = path_split("/foo/bar"), + {"foo", "bar"} = path_split("foo/bar"), + {"bar", ""} = path_split("bar"), + ok. + +test_urlsplit() -> + {"", "", "/foo", "", "bar?baz"} = urlsplit("/foo#bar?baz"), + {"http", "host:port", "/foo", "", "bar?baz"} = + urlsplit("http://host:port/foo#bar?baz"), + ok. + +test_urlsplit_path() -> + {"/foo/bar", "", ""} = urlsplit_path("/foo/bar"), + {"/foo", "baz", ""} = urlsplit_path("/foo?baz"), + {"/foo", "", "bar?baz"} = urlsplit_path("/foo#bar?baz"), + {"/foo", "", "bar?baz#wibble"} = urlsplit_path("/foo#bar?baz#wibble"), + {"/foo", "bar", "baz"} = urlsplit_path("/foo?bar#baz"), + {"/foo", "bar?baz", "baz"} = urlsplit_path("/foo?bar?baz#baz"), + ok. + +test_urlunsplit() -> + "/foo#bar?baz" = urlunsplit({"", "", "/foo", "", "bar?baz"}), + "http://host:port/foo#bar?baz" = + urlunsplit({"http", "host:port", "/foo", "", "bar?baz"}), + ok. + +test_urlunsplit_path() -> + "/foo/bar" = urlunsplit_path({"/foo/bar", "", ""}), + "/foo?baz" = urlunsplit_path({"/foo", "baz", ""}), + "/foo#bar?baz" = urlunsplit_path({"/foo", "", "bar?baz"}), + "/foo#bar?baz#wibble" = urlunsplit_path({"/foo", "", "bar?baz#wibble"}), + "/foo?bar#baz" = urlunsplit_path({"/foo", "bar", "baz"}), + "/foo?bar?baz#baz" = urlunsplit_path({"/foo", "bar?baz", "baz"}), + ok. + +test_join() -> + "foo,bar,baz" = join(["foo", "bar", "baz"], $,), + "foo,bar,baz" = join(["foo", "bar", "baz"], ","), + "foo bar" = join([["foo", " bar"]], ","), + "foo bar,baz" = join([["foo", " bar"], "baz"], ","), + "foo" = join(["foo"], ","), + "foobarbaz" = join(["foo", "bar", "baz"], ""), + ok. + +test_quote_plus() -> + "foo" = quote_plus(foo), + "1" = quote_plus(1), + "foo" = quote_plus("foo"), + "foo+bar" = quote_plus("foo bar"), + "foo%0A" = quote_plus("foo\n"), + "foo%0A" = quote_plus("foo\n"), + "foo%3B%26%3D" = quote_plus("foo;&="), + ok. + +test_unquote() -> + "foo bar" = unquote("foo+bar"), + "foo bar" = unquote("foo%20bar"), + "foo\r\n" = unquote("foo%0D%0A"), + ok. + +test_urlencode() -> + "foo=bar&baz=wibble+%0D%0A&z=1" = urlencode([{foo, "bar"}, + {"baz", "wibble \r\n"}, + {z, 1}]), + ok. + +test_parse_qs() -> + [{"foo", "bar"}, {"baz", "wibble \r\n"}, {"z", "1"}] = + parse_qs("foo=bar&baz=wibble+%0D%0A&z=1"), + ok. diff --git a/src/mochiweb/reloader.erl b/src/mochiweb/reloader.erl new file mode 100644 index 00000000..fcb27c1c --- /dev/null +++ b/src/mochiweb/reloader.erl @@ -0,0 +1,107 @@ +%% @copyright 2007 Mochi Media, Inc. +%% @author Matthew Dempsky <matthew@mochimedia.com> +%% +%% @doc Erlang module for automatically reloading modified modules +%% during development. + +-module(reloader). +-author("Matthew Dempsky <matthew@mochimedia.com>"). + +-include_lib("kernel/include/file.hrl"). + +-behaviour(gen_server). +-export([start/0, start_link/0]). +-export([stop/0]). +-export([init/1, handle_call/3, handle_cast/2, handle_info/2, terminate/2, code_change/3]). + +-record(state, {last, tref}). + +%% External API + +%% @spec start() -> ServerRet +%% @doc Start the reloader. +start() -> + gen_server:start({local, ?MODULE}, ?MODULE, [], []). + +%% @spec start_link() -> ServerRet +%% @doc Start the reloader. +start_link() -> + gen_server:start_link({local, ?MODULE}, ?MODULE, [], []). + +%% @spec stop() -> ok +%% @doc Stop the reloader. +stop() -> + gen_server:call(?MODULE, stop). + +%% gen_server callbacks + +%% @spec init([]) -> {ok, State} +%% @doc gen_server init, opens the server in an initial state. +init([]) -> + {ok, TRef} = timer:send_interval(timer:seconds(1), doit), + {ok, #state{last = stamp(), tref = TRef}}. + +%% @spec handle_call(Args, From, State) -> tuple() +%% @doc gen_server callback. +handle_call(stop, _From, State) -> + {stop, shutdown, stopped, State}; +handle_call(_Req, _From, State) -> + {reply, {error, badrequest}, State}. + +%% @spec handle_cast(Cast, State) -> tuple() +%% @doc gen_server callback. +handle_cast(_Req, State) -> + {noreply, State}. + +%% @spec handle_info(Info, State) -> tuple() +%% @doc gen_server callback. +handle_info(doit, State) -> + Now = stamp(), + doit(State#state.last, Now), + {noreply, State#state{last = Now}}; +handle_info(_Info, State) -> + {noreply, State}. + +%% @spec terminate(Reason, State) -> ok +%% @doc gen_server termination callback. +terminate(_Reason, State) -> + {ok, cancel} = timer:cancel(State#state.tref), + ok. + + +%% @spec code_change(_OldVsn, State, _Extra) -> State +%% @doc gen_server code_change callback (trivial). +code_change(_Vsn, State, _Extra) -> + {ok, State}. + +%% Internal API + +doit(From, To) -> + [case file:read_file_info(Filename) of + {ok, FileInfo} when FileInfo#file_info.mtime >= From, + FileInfo#file_info.mtime < To -> + io:format("Reloading ~p ...", [Module]), + code:purge(Module), + case code:load_file(Module) of + {module, Module} -> + io:format(" ok.~n"), + reload; + {error, Reason} -> + io:format(" ~p.~n", [Reason]), + error + end; + {ok, _} -> + unmodified; + {error, enoent} -> + %% The Erlang compiler deletes existing .beam files if + %% recompiling fails. Maybe it's worth spitting out a + %% warning here, but I'd want to limit it to just once. + gone; + {error, Reason} -> + io:format("Error reading ~s's file info: ~p~n", + [Filename, Reason]), + error + end || {Module, Filename} <- code:all_loaded(), is_list(Filename)]. + +stamp() -> + erlang:localtime(). |