Permalink
Browse files

[feature] stdlib: missing ssl param for server

  • Loading branch information...
1 parent 9ddf00d commit 97e3f739bc2c0fc292de481735b88e3b23693633 Hugo Heuzard committed Jun 28, 2011
Showing with 54 additions and 35 deletions.
  1. +25 −15 libnet/httpServer.ml
  2. +20 −16 opabsl/mlbsl/bslNet.ml
  3. +2 −1 stdlib/core/web/server/server.opa
  4. +7 −3 stdlib/core/web/server/server_private.opa
View
@@ -436,6 +436,8 @@ type options =
ssl_ca_path : string;
ssl_client_ca_file : string;
ssl_client_cert_path : string;
+ ssl_certificate : SslAS.ssl_certificate option;
+ ssl_verify_params : SslAS.ssl_verify_params option;
pid_file : string option;
dialog : string;
request_size_max : int;
@@ -521,6 +523,8 @@ let default_options =
ssl_ca_path = "";
ssl_client_ca_file = "";
ssl_client_cert_path = "";
+ ssl_certificate = None;
+ ssl_verify_params = None;
pid_file = None;
dialog = "default";
request_size_max = 10*1024*1024;
@@ -753,23 +757,29 @@ let spec_args name =
(* From httpServerOptions *)
let make_ssl_cert opt =
- if opt.ssl_cert <> "" then
- if opt.ssl_key <> "" then
- Some (SslAS.make_ssl_certificate opt.ssl_cert opt.ssl_key opt.ssl_pass)
- else begin
- Logger.critical "Error : ssl-cert option MUST be used with ssl-key option";
- exit 1
- end
- else
- None
+ match opt.ssl_certificate with
+ | Some x -> Some x
+ | None ->
+ if opt.ssl_cert <> "" then
+ if opt.ssl_key <> "" then
+ Some (SslAS.make_ssl_certificate opt.ssl_cert opt.ssl_key opt.ssl_pass)
+ else begin
+ Logger.critical "Error : ssl-cert option MUST be used with ssl-key option";
+ exit 1
+ end
+ else
+ None
let make_ssl_verify opt =
- if opt.ssl_ca_file <> "" || opt.ssl_ca_path <> "" || opt.ssl_client_cert_path <> "" then
- Some (SslAS.make_ssl_verify_params ~client_ca_file:opt.ssl_client_ca_file
- ~accept_fun:opt.ssl_accept_fun ~always:opt.ssl_always
- opt.ssl_ca_file opt.ssl_ca_path opt.ssl_client_cert_path)
- else
- None
+ match opt.ssl_verify_params with
+ | Some x -> Some x
+ | None ->
+ if opt.ssl_ca_file <> "" || opt.ssl_ca_path <> "" || opt.ssl_client_cert_path <> "" then
+ Some (SslAS.make_ssl_verify_params ~client_ca_file:opt.ssl_client_ca_file
+ ~accept_fun:opt.ssl_accept_fun ~always:opt.ssl_always
+ opt.ssl_ca_file opt.ssl_ca_path opt.ssl_client_cert_path)
+ else
+ None
let init_server opt runtime server_info =
if opt.print_log_info then HSCm.init_logger ();
View
@@ -36,6 +36,11 @@ let default_scheduler = BslScheduler.opa
##opa-type HttpRequest.part
+##extern-type SSL.private_key = SslAS.ssl_certificate
+##extern-type SSL.policy = SslAS.ssl_verify_params
+##extern-type SSL.certificate = Ssl.certificate
+##extern-type SSL.secure_type = SslAS.secure_type
+
(** Provides functions from OPA HTTP server, manipulating HTTP
request, make HTTP response, etc.*)
@@ -253,15 +258,17 @@ let default_scheduler = BslScheduler.opa
option(string), \
option(string), \
option(string), \
+ SSL.secure_type, \
(WebInfo.private.native -> void), \
(string, HttpRequest.msg_list, int -> bool) ->\
void
- let init_server name port certfileo privkeyo passwdo dispatcher ontransfer =
+ let init_server name port certfileo privkeyo passwdo secure_type dispatcher ontransfer =
let sop = function | Some s -> s | None -> "" in
let dialog_name = Printf.sprintf "%s-dialog" name in
let http_server_name = Printf.sprintf "%s" name in
let dialog _ _sched = dispatcher in
let callback (name,hdrs) i _buf = ontransfer name hdrs i (*buf*) in
+ let ssl_certificate,ssl_verify_params=secure_type in
Runtime.add_httpDialog dialog_name (HttpDialog.options_with_dialog dialog);
Runtime.add_httpServer http_server_name
{HttpServer.default_options with
@@ -271,6 +278,8 @@ let default_scheduler = BslScheduler.opa
dialog = dialog_name;
port = port;
callback = Some callback;
+ ssl_certificate = ssl_certificate;
+ ssl_verify_params = ssl_verify_params;
}
(*##register init_server_cps : string, int, option(string), option(string), option(string), continuation(WebInfo.private.native), (int, int, bool, string, string, string -> void) -> unit*)
@@ -280,11 +289,12 @@ let default_scheduler = BslScheduler.opa
option(string), \
option(string), \
option(string), \
+ SSL.secure_type, \
continuation(WebInfo.private.native), \
(string, HttpRequest.msg_list, int -> bool) -> \
void
- let init_server_cps name port certfileo privkeyo passwdo dispatcher ontransfer =
- init_server name port certfileo privkeyo passwdo
+ let init_server_cps name port certfileo privkeyo passwdo secure_type dispatcher ontransfer =
+ init_server name port certfileo privkeyo passwdo secure_type
(fun winfo -> QmlCpsServerLib.return dispatcher winfo)
ontransfer
@@ -318,12 +328,6 @@ let default_scheduler = BslScheduler.opa
##endmodule
-
-##extern-type SSL.private_key = SslAS.ssl_certificate
-##extern-type SSL.policy = SslAS.ssl_verify_params
-##extern-type SSL.certificate = Ssl.certificate
-##extern-type SSL.secure_type = SslAS.secure_type
-
##module ssl
(**
Construct a SSL certificate + private key
@@ -334,7 +338,7 @@ let default_scheduler = BslScheduler.opa
@param privkey Path to a file containing the private key
@param password The password to use if private key protected
*)
- ##register make_key: option(string), option(string), string, string, string -> opa[SSL.private_key]
+ ##register make_key: option(string), option(string), string, string, string -> SSL.private_key
let make_key cafile capath certfile privkey password = SslAS.make_ssl_certificate ?cafile ?capath certfile privkey password
(**
@@ -348,21 +352,21 @@ let default_scheduler = BslScheduler.opa
@param capath A directory containing CA certificates in PEM format, used for verification
@param certpath A directory containing client certificates in PEM format
*)
- ##register make_policy: option(string), option(opa[SSL.certificate] -> bool), bool, string, string, string -> opa[SSL.policy]
+ ##register make_policy: option(string), option(SSL.certificate -> bool), bool, string, string, string -> SSL.policy
let make_policy client_ca_file fallback always cafile capath certpath =
SslAS.make_ssl_verify_params ?client_ca_file ?accept_fun:fallback ~always cafile capath certpath
- ##register make_secure_type: option(opa[SSL.private_key]), option(opa[SSL.policy]) -> SSL.secure_type
+ ##register make_secure_type: option(SSL.private_key), option(SSL.policy) -> SSL.secure_type
let make_secure_type key policy = (key, policy)
(**
Consult the issuer of a certificate
*)
- ##register get_issuer \ `Ssl.get_issuer` : opa[SSL.certificate] -> string
+ ##register get_issuer \ `Ssl.get_issuer` : SSL.certificate -> string
(**
Consult the subject of a certificate
*)
- ##register get_subject \ `Ssl.get_subject` : opa[SSL.certificate] -> string
+ ##register get_subject \ `Ssl.get_subject` : SSL.certificate -> string
##endmodule
@@ -412,8 +416,8 @@ let default_scheduler = BslScheduler.opa
option(string), \
bool, \
option(string), \
- option(opa[SSL.private_key]), \
- option(opa[SSL.policy]), \
+ option(SSL.private_key), \
+ option(SSL.policy), \
option(time_t), \
option(string), \
option(string), \
@@ -16,7 +16,7 @@
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*/
-import stdlib.core.{parser, map, rpc.core, web.{core,context,resource}}
+import stdlib.core.{security.ssl, parser, map, rpc.core, web.{core,context,resource}}
/**
* Defining web services.
@@ -85,6 +85,7 @@ type Server.encryption =
private_key: string/**Name of a file containing a SSL-issued private key*/
password: string/**A full-text password*/
}
+/ { secure_type: SSL.secure_type}
/**
* Specification of a service.
@@ -327,7 +327,7 @@ Server_private = {{
make_server(service:service) =
/* Select bypasses */
init_server = %% BslNet.Http_server.init_server_cps %%
- : _, _, _, _, _, continuation(WebInfo.private.native), _ -> void
+ : _, _, _, _, _, _, continuation(WebInfo.private.native), _ -> void
set_cookie_expiry_callback = %% BslNet.Http_server.set_cookie_expiry_callback %%
: (string, string -> void) -> void
complete_dispatcher = %%BslDispatcher.complete_dispatcher_cps%%
@@ -348,11 +348,15 @@ Server_private = {{
match service.encryption with
| {no_encryption} ->
init_server(service.server_name, service.port,
- {none}, {none}, {none},
+ {none}, {none}, {none}, (SSL.make_secure_type(none,none)),
dispatcher, bogus_ontransfer)
| ~{ certificate private_key password } ->
init_server(service.server_name, service.port,
- some(certificate), some(private_key), some(password),
+ some(certificate), some(private_key), some(password), (SSL.make_secure_type(none,none)),
+ dispatcher, bogus_ontransfer)
+ | ~{ secure_type } ->
+ init_server(service.server_name, service.port,
+ none, none, none, secure_type,
dispatcher, bogus_ontransfer)
make_server

0 comments on commit 97e3f73

Please sign in to comment.