summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Makefile.am2
-rw-r--r--src/couch_inets/Makefile.am177
-rw-r--r--src/couch_inets/couch_inets.app84
-rw-r--r--src/couch_inets/ftp.erl1597
-rw-r--r--src/couch_inets/ftp_internal.hrl19
-rw-r--r--src/couch_inets/ftp_progress.erl125
-rw-r--r--src/couch_inets/ftp_response.erl190
-rw-r--r--src/couch_inets/ftp_sup.erl57
-rw-r--r--src/couch_inets/http.erl396
-rw-r--r--src/couch_inets/http_base_64.erl126
-rw-r--r--src/couch_inets/http_chunk.erl289
-rw-r--r--src/couch_inets/http_cookie.erl389
-rw-r--r--src/couch_inets/http_internal.hrl105
-rw-r--r--src/couch_inets/http_request.erl278
-rw-r--r--src/couch_inets/http_response.erl206
-rw-r--r--src/couch_inets/http_transport.erl291
-rw-r--r--src/couch_inets/http_uri.erl113
-rw-r--r--src/couch_inets/http_util.erl171
-rw-r--r--src/couch_inets/httpc_handler.erl953
-rw-r--r--src/couch_inets/httpc_internal.hrl87
-rw-r--r--src/couch_inets/httpc_manager.erl475
-rw-r--r--src/couch_inets/httpc_request.erl193
-rw-r--r--src/couch_inets/httpc_response.erl320
-rw-r--r--src/couch_inets/httpc_sup.erl70
-rw-r--r--src/couch_inets/httpd.erl516
-rw-r--r--src/couch_inets/httpd.hrl78
-rw-r--r--src/couch_inets/httpd_acceptor.erl155
-rw-r--r--src/couch_inets/httpd_acceptor_sup.erl84
-rw-r--r--src/couch_inets/httpd_cgi.erl122
-rw-r--r--src/couch_inets/httpd_conf.erl720
-rw-r--r--src/couch_inets/httpd_esi.erl106
-rw-r--r--src/couch_inets/httpd_example.erl143
-rw-r--r--src/couch_inets/httpd_instance_sup.erl193
-rw-r--r--src/couch_inets/httpd_manager.erl829
-rw-r--r--src/couch_inets/httpd_misc_sup.erl89
-rw-r--r--src/couch_inets/httpd_request.erl337
-rw-r--r--src/couch_inets/httpd_request_handler.erl516
-rw-r--r--src/couch_inets/httpd_response.erl377
-rw-r--r--src/couch_inets/httpd_script_env.erl141
-rw-r--r--src/couch_inets/httpd_socket.erl62
-rw-r--r--src/couch_inets/httpd_sup.erl137
-rw-r--r--src/couch_inets/httpd_util.erl718
-rw-r--r--src/couch_inets/inets.erl34
-rw-r--r--src/couch_inets/inets_app.erl28
-rw-r--r--src/couch_inets/inets_internal.hrl27
-rw-r--r--src/couch_inets/inets_sup.erl106
-rw-r--r--src/couch_inets/mod_actions.erl92
-rw-r--r--src/couch_inets/mod_alias.erl180
-rw-r--r--src/couch_inets/mod_auth.erl784
-rw-r--r--src/couch_inets/mod_auth.hrl27
-rw-r--r--src/couch_inets/mod_auth_dets.erl228
-rw-r--r--src/couch_inets/mod_auth_mnesia.erl282
-rw-r--r--src/couch_inets/mod_auth_plain.erl295
-rw-r--r--src/couch_inets/mod_auth_server.erl374
-rw-r--r--src/couch_inets/mod_browser.erl247
-rw-r--r--src/couch_inets/mod_cgi.erl331
-rw-r--r--src/couch_inets/mod_dir.erl281
-rw-r--r--src/couch_inets/mod_disk_log.erl396
-rw-r--r--src/couch_inets/mod_esi.erl432
-rw-r--r--src/couch_inets/mod_get.erl125
-rw-r--r--src/couch_inets/mod_head.erl73
-rw-r--r--src/couch_inets/mod_htaccess.erl1075
-rw-r--r--src/couch_inets/mod_include.erl594
-rw-r--r--src/couch_inets/mod_log.erl253
-rw-r--r--src/couch_inets/mod_range.erl416
-rw-r--r--src/couch_inets/mod_responsecontrol.erl301
-rw-r--r--src/couch_inets/mod_security.erl294
-rw-r--r--src/couch_inets/mod_security_server.erl628
-rw-r--r--src/couch_inets/mod_trace.erl87
-rw-r--r--src/couch_inets/tftp.erl310
-rw-r--r--src/couch_inets/tftp.hrl47
-rw-r--r--src/couch_inets/tftp_binary.erl181
-rw-r--r--src/couch_inets/tftp_engine.erl1121
-rw-r--r--src/couch_inets/tftp_file.erl338
-rw-r--r--src/couch_inets/tftp_lib.erl418
-rw-r--r--src/couch_inets/tftp_sup.erl81
-rw-r--r--src/couchdb/Makefile.am8
-rw-r--r--src/couchdb/cjson.erl2
-rw-r--r--src/couchdb/couch.app.tpl.in5
-rw-r--r--src/couchdb/couch_db.erl15
-rw-r--r--src/couchdb/couch_doc.erl3
-rw-r--r--src/couchdb/couch_httpd.erl832
-rw-r--r--src/couchdb/couch_rep.erl9
-rw-r--r--src/couchdb/couch_server_sup.erl18
-rw-r--r--src/couchdb/mod_couch.erl890
-rw-r--r--src/mochiweb/Makefile.am75
-rw-r--r--src/mochiweb/mochihex.erl75
-rw-r--r--src/mochiweb/mochijson.erl529
-rw-r--r--src/mochiweb/mochijson2.erl509
-rw-r--r--src/mochiweb/mochinum.erl289
-rw-r--r--src/mochiweb/mochiweb.app29
-rw-r--r--src/mochiweb/mochiweb.erl101
-rw-r--r--src/mochiweb/mochiweb_app.erl20
-rw-r--r--src/mochiweb/mochiweb_charref.erl295
-rw-r--r--src/mochiweb/mochiweb_cookies.erl250
-rw-r--r--src/mochiweb/mochiweb_echo.erl31
-rw-r--r--src/mochiweb/mochiweb_headers.erl178
-rw-r--r--src/mochiweb/mochiweb_html.erl760
-rw-r--r--src/mochiweb/mochiweb_http.erl132
-rw-r--r--src/mochiweb/mochiweb_multipart.erl428
-rw-r--r--src/mochiweb/mochiweb_request.erl700
-rw-r--r--src/mochiweb/mochiweb_response.erl52
-rw-r--r--src/mochiweb/mochiweb_skel.erl71
-rw-r--r--src/mochiweb/mochiweb_socket_server.erl234
-rw-r--r--src/mochiweb/mochiweb_sup.erl34
-rw-r--r--src/mochiweb/mochiweb_util.erl486
-rw-r--r--src/mochiweb/reloader.erl107
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 &lt; 0;
+%% trunc(F) + 1 when F &gt; 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() ->
+ <<"&amp;quot;\"word &lt;&lt;up!&amp;quot;">> =
+ escape(<<"&quot;\"word <<up!&quot;">>),
+ ok.
+
+test_escape_attr() ->
+ <<"&amp;quot;&quot;word &lt;&lt;up!&amp;quot;">> =
+ escape_attr(<<"&quot;\"word <<up!&quot;">>),
+ ok.
+
+escape([], Acc) ->
+ list_to_binary(lists:reverse(Acc));
+escape("<" ++ Rest, Acc) ->
+ escape(Rest, lists:reverse("&lt;", Acc));
+escape(">" ++ Rest, Acc) ->
+ escape(Rest, lists:reverse("&gt;", Acc));
+escape("&" ++ Rest, Acc) ->
+ escape(Rest, lists:reverse("&amp;", 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("&lt;", Acc));
+escape_attr(">" ++ Rest, Acc) ->
+ escape_attr(Rest, lists:reverse("&gt;", Acc));
+escape_attr("&" ++ Rest, Acc) ->
+ escape_attr(Rest, lists:reverse("&amp;", Acc));
+escape_attr([?QUOTE | Rest], Acc) ->
+ escape_attr(Rest, lists:reverse("&quot;", 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[&lt;<this<!-- is -->CDATA>&gt;]]></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">>}],
+ [<<"&lt;<this<!-- is -->CDATA>&gt;">>]}]},
+ 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().