From: Adam Chlipala <adamc@hcoop.net>
Date: Sun, 18 Feb 2007 01:14:28 +0000 (+0000)
Subject: SSL certificates
X-Git-Tag: release_2010-11-19~258
X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/commitdiff_plain/434a7b1fbf0e810a19b9b4038edd28c981908cbd

SSL certificates
---

diff --git a/lib/apache.dtl b/lib/apache.dtl
index d80d7ef..93fb3a3 100644
--- a/lib/apache.dtl
+++ b/lib/apache.dtl
@@ -9,13 +9,20 @@ context Vhost;
 {{A WWW virtual host}}
 
 extern type suexec_flag;
-extern val suexec_flag : bool -> suexec_flag;
 {{Whether or not to use Suexec with a vhost.
-[suexec_flag] fails when passed [false] by a user without the 'www' privilege.}}
+For users with the 'www' privilege, this type is identical to [bool].
+For others, it has only one value, [true].}}
+
+extern type ssl_cert_path;
+{{Filesystem path to an SSL certificate in your 'cert' list}}
+
+extern type ssl;
+extern val no_ssl : ssl;
+extern val use_cert : ssl_cert_path -> ssl;
 
 extern val vhost : host -> Vhost => [Domain]
 	{WebNodes : [web_node],
-	 SSL : bool,
+	 SSL : ssl,
 	 User : your_user,
 	 Group : your_group,
 	 DocumentRoot : your_path,
diff --git a/src/main.sml b/src/main.sml
index 29d2b37..6585144 100644
--- a/src/main.sml
+++ b/src/main.sml
@@ -665,6 +665,7 @@ fun regenerate context =
 	    end
 		handle IO.Io _ => ()
 		     | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n")
+		     | ErrorMsg.Error => print ("User " ^ user ^ " had a compilation error.\n")
     in
 	app contactNode Config.nodeIps;
 	Env.pre ();
diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml
index 558c998..9a08a84 100644
--- a/src/plugins/apache.sml
+++ b/src/plugins/apache.sml
@@ -74,6 +74,19 @@ val _ = Env.type_one "location"
 	Env.string
 	validLocation
 
+fun validCert s = Acl.query {user = Domain.getUser (),
+			     class = "cert",
+			     value = s}
+
+val _ = Env.type_one "ssl_cert_path"
+	Env.string
+	validCert
+
+fun ssl e = case e of
+		(EVar "no_ssl", _) => SOME NONE
+	      | (EApp ((EVar "use_cert", _), s), _) => Option.map SOME (Env.string s)
+	      | _ => NONE
+
 val dl = ErrorMsg.dummyLoc
 
 val _ = Defaults.registerDefault ("WebNodes",
@@ -102,8 +115,7 @@ val _ = Defaults.registerDefault ("ServerAdmin",
 
 val _ = Defaults.registerDefault ("SuExec",
 				  (TBase "suexec_flag", dl),
-				  (fn () => (EApp ((EVar "suexec_flag", dl),
-						   (EVar "true", dl)), dl)))
+				  (fn () => (EVar "true", dl)))
 
 val redirect_code = fn (EVar "temp", _) => SOME "temp"
 		     | (EVar "permanent", _) => SOME "permanent"
@@ -246,10 +258,15 @@ val () = Slave.registerFileHandler (fn fs =>
 											{dir = realLogDir,
 											 file = Slave.hostname ()}
 								   val {base, ...} = OS.Path.splitBaseExt (#file spl)
+
+								   val realLogDir = OS.Path.joinDirFile
+											{dir = realLogDir,
+											 file = base}
 							       in
-								   OS.Path.joinDirFile
-								       {dir = realLogDir,
-									file = base}
+								   if String.isSuffix ".vhost_ssl" (#file spl) then
+								       realLogDir ^ ".ssl"
+								   else
+								       realLogDir
 							       end
 						       in
 							   vhostsChanged := true;
@@ -354,25 +371,22 @@ fun registerAliaser f =
 	aliaser := (fn x => (old x; f x))
     end
 
-fun suexec_flag (EApp ((EVar "suexec_flag", _), e), _) = Env.bool e
-  | suexec_flag _ = NONE
-
 val () = Env.containerV_one "vhost"
 	 ("host", Env.string)
 	 (fn (env, host) =>
 	     let
 		 val nodes = Env.env (Env.list Env.string) (env, "WebNodes")
 
-		 val ssl = Env.env Env.bool (env, "SSL")
+		 val ssl = Env.env ssl (env, "SSL")
 		 val user = Env.env Env.string (env, "User")
 		 val group = Env.env Env.string (env, "Group")
 		 val docroot = Env.env Env.string (env, "DocumentRoot")
 		 val sadmin = Env.env Env.string (env, "ServerAdmin")
-		 val suexec = Env.env suexec_flag (env, "SuExec")
+		 val suexec = Env.env Env.bool (env, "SuExec")
 
 		 val fullHost = host ^ "." ^ Domain.currentDomain ()
-		 val vhostId = fullHost ^ (if ssl then ".ssl" else "")
-		 val confFile = fullHost ^ (if ssl then ".vhost_ssl" else ".vhost")
+		 val vhostId = fullHost ^ (if Option.isSome ssl then ".ssl" else "")
+		 val confFile = fullHost ^ (if Option.isSome ssl then ".vhost_ssl" else ".vhost")
 	     in
 		 currentVhost := fullHost;
 		 currentVhostId := vhostId;
@@ -389,10 +403,9 @@ val () = Env.containerV_one "vhost"
 					   TextIO.output (file, "\n<VirtualHost ");
 					   TextIO.output (file, Domain.nodeIp node);
 					   TextIO.output (file, ":");
-					   TextIO.output (file, if ssl then
-								    "443"
-								else
-								    "80");
+					   TextIO.output (file, case ssl of
+								    SOME _ => "443"
+								  | NONE => "80");
 					   TextIO.output (file, ">\n");
 					   TextIO.output (file, "\tErrorLog ");
 					   TextIO.output (file, Config.homeBase);
@@ -428,10 +441,11 @@ val () = Env.containerV_one "vhost"
 		 write docroot;
 		 write "\n\tServerAdmin ";
 		 write sadmin;
-		 if ssl then
-		     (write "\n\tSSLEngine on")
-		 else
-		     ();
+		 case ssl of
+		     SOME cert =>
+		     (write "\n\tSSLEngine on\n\tSSLCertificateFile ";
+		      write cert)
+		   | NONE => ();
 		 write "\n";
 		 !pre {user = user, nodes = nodes, id = vhostId, hostname = fullHost}
 	     end,