Apache auth

diff --git a/lib/apache_auth.dtl b/lib/apache_auth.dtl
new file mode 100644 (file)
index 0000000..42eb389
--- /dev/null
+++ b/lib/apache_auth.dtl
@@ -0,0 +1,42 @@
+{{Controlling who can access sections of a virtual host}}
+
+extern type authType;
+extern val basic : authType;
+extern val digest : authType;
+extern val authType : authType -> [Location];
+{{See <a href="http://httpd.apache.org/docs/2.0/mod/core.html#authtype">the
+  Apache documentation</a>.}}
+
+extern val authName : no_newlines -> [Location];
+{{See <a href="http://httpd.apache.org/docs/2.0/mod/core.html#authname">the
+  Apache documentation</a>.}}
+
+extern val authUserFile : your_path -> [Location];
+{{See <a href="http://httpd.apache.org/docs/2.0/mod/core.html#authuserfile">the
+  Apache documentation</a>.}}
+
+extern val requireValidUser : [Location];
+extern val requireUser : [user] -> [Location];
+extern val requireGroup : [group] -> [Location];
+{{See <a href="http://httpd.apache.org/docs/2.0/mod/core.html#require">the
+  Apache documentation</a>.}}
+
+extern val orderAllowDeny : [Location];
+extern val orderDenyAllow : [Location];
+{{See <a href="http://httpd.apache.org/docs/2.0/mod/mod_access.html#order">the
+  Apache documentation</a>.}}
+
+extern val allowFromAll : [Location];
+extern val allowFrom : [no_spaces] -> [Location];
+{{See <a href="http://httpd.apache.org/docs/2.0/mod/mod_access.html#allow">the
+  Apache documentation</a>.}}
+
+extern val denyFromAll : [Location];
+extern val denyFrom : [no_spaces] -> [Location];
+{{See <a href="http://httpd.apache.org/docs/2.0/mod/mod_access.html#deny">the
+  Apache documentation</a>.}}
+
+extern val satisfyAll : [Location];
+extern val satisfyAny : [Location];
+{{See <a href="http://httpd.apache.org/docs/2.0/mod/core.html#satisfy">the
+  Apache documentation</a>.}}

diff --git a/lib/domain.dtl b/lib/domain.dtl
index 34b6859..69b0f5e 100644 (file)
--- a/lib/domain.dtl
+++ b/lib/domain.dtl
@@ -24,6 +24,10 @@ extern type your_domain_host;
 extern type node;
 {{The name of a server controlled by domtool}}
 
 extern type node;
 {{The name of a server controlled by domtool}}
 

+extern type user;
+extern type group;
+{{UNIX users and groups}}
+

 extern type your_user;
 extern type your_group;
 {{UNIX users and groups that you're allowed to run as}}
 extern type your_user;
 extern type your_group;
 {{UNIX users and groups that you're allowed to run as}}

diff --git a/src/domain.sml b/src/domain.sml
index 224755f..4b4042f 100644 (file)
--- a/src/domain.sml
+++ b/src/domain.sml
@@ -75,13 +75,17 @@ fun yourDomainHost s =
     let
        val (pref, suf) = Substring.splitl (fn ch => ch <> #".") (Substring.full s)
     in
     let
        val (pref, suf) = Substring.splitl (fn ch => ch <> #".") (Substring.full s)
     in

-       print ("pref[" ^ Substring.string pref ^ "] suf[" ^ Substring.string suf ^ "]\n");

        Substring.size suf > 0
        andalso validHost (Substring.string pref)
        andalso yourDomain (Substring.string
                               (Substring.slice (suf, 1, NONE)))
     end
 
        Substring.size suf > 0
        andalso validHost (Substring.string pref)
        andalso yourDomain (Substring.string
                               (Substring.slice (suf, 1, NONE)))
     end
 

+fun validUser s = size s > 0 andalso size s < 20
+                 andalso CharVector.all Char.isAlphaNum s
+
+val validGroup = validUser
+

 val _ = Env.type_one "no_spaces"
                     Env.string
                     (CharVector.all (fn ch => not (Char.isSpace ch)))
 val _ = Env.type_one "no_spaces"
                     Env.string
                     (CharVector.all (fn ch => not (Char.isSpace ch)))


@@ -109,6 +113,14 @@ val _ = Env.type_one "your_domain_host"
        Env.string
        yourDomainHost
 
        Env.string
        yourDomainHost
 

+val _ = Env.type_one "user"
+       Env.string
+       validUser
+
+val _ = Env.type_one "group"
+       Env.string
+       validGroup
+

 val _ = Env.type_one "your_user"
        Env.string
        yourUser
 val _ = Env.type_one "your_user"
        Env.string
        yourUser

diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml
index 4887043..7689860 100644 (file)
--- a/src/plugins/apache.sml
+++ b/src/plugins/apache.sml
@@ -378,4 +378,86 @@ val () = Env.action_one "serverAlias"
              write host;
              write "\n"))
 
              write host;
              write "\n"))
 

+val authType = fn (EVar "basic", _) => SOME "basic"
+               | (EVar "digest", _) => SOME "digest"
+               | _ => NONE
+
+val () = Env.action_one "authType"
+        ("type", authType)
+        (fn ty =>
+            (write "\tAuthType ";
+             write ty;
+             write "\n"))
+
+val () = Env.action_one "authName"
+        ("name", Env.string)
+        (fn name =>
+            (write "\tAuthName \"";
+             write name;
+             write "\"\n"))
+
+val () = Env.action_one "authUserFile"
+        ("file", Env.string)
+        (fn name =>
+            (write "\tAuthUserFile ";
+             write name;
+             write "\n"))
+
+val () = Env.action_none "requireValidUser"
+        (fn () => write "\tRequire valid-user\n")
+
+val () = Env.action_one "requireUser"
+        ("users", Env.list Env.string)
+        (fn names =>
+            case names of
+                [] => ()
+              | _ => (write "\tRequire user";
+                      app (fn name => (write " "; write name)) names;
+                      write "\n"))
+
+val () = Env.action_one "requireGroup"
+        ("groups", Env.list Env.string)
+        (fn names =>
+            case names of
+                [] => ()
+              | _ => (write "\tRequire group";
+                      app (fn name => (write " "; write name)) names;
+                      write "\n"))
+
+val () = Env.action_none "orderAllowDeny"
+        (fn () => write "\tOrder allow,deny\n")
+
+val () = Env.action_none "orderDenyAllow"
+        (fn () => write "\tOrder deny,allow\n")
+
+val () = Env.action_none "allowFromAll"
+        (fn () => write "\tAllow from all\n")
+
+val () = Env.action_one "allowFrom"
+        ("entries", Env.list Env.string)
+        (fn names =>
+            case names of
+                [] => ()
+              | _ => (write "\tAllow from";
+                      app (fn name => (write " "; write name)) names;
+                      write "\n"))
+
+val () = Env.action_none "denyFromAll"
+        (fn () => write "\tDeny from all\n")
+
+val () = Env.action_one "denyFrom"
+        ("entries", Env.list Env.string)
+        (fn names =>
+            case names of
+                [] => ()
+              | _ => (write "\tDeny from";
+                      app (fn name => (write " "; write name)) names;
+                      write "\n"))
+
+val () = Env.action_none "satisfyAll"
+        (fn () => write "\tSatisfy all\n")
+
+val () = Env.action_none "satisfyAny"
+        (fn () => write "\tSatisfy any\n")
+

 end
 end

diff --git a/tests/testApache.dtl b/tests/testApache.dtl
index 9c28fcd..acade80 100644 (file)
--- a/tests/testApache.dtl
+++ b/tests/testApache.dtl
@@ -44,5 +44,20 @@ domain "hcoop.net" with
                alias "/doc/mailman" "/home/adamc/mailman";
 
                directoryIndex ["index.sml", "index.h", "index.v"]
                alias "/doc/mailman" "/home/adamc/mailman";
 
                directoryIndex ["index.sml", "index.h", "index.v"]

-       end
+       end;
+
+       vhost "secret" with
+               location "/" with
+                       authType basic;
+                       authName "Herman the skunk";
+                       authUserFile "/home/adamc/passwds";
+
+                       requireValidUser;
+                       requireUser ["freddy", "flicky"];
+                       requireGroup ["awesome"];
+
+                       orderDenyAllow;
+                       satisfyAny
+               end
+       end;

 end
 end