From 2aeb9eece3df3aacb6813db7b151256c2e49a1c2 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Mon, 7 Aug 2006 03:40:49 +0000 Subject: [PATCH] Apache auth --- lib/apache_auth.dtl | 42 ++++++++++++++++++++++ lib/domain.dtl | 4 +++ src/domain.sml | 14 +++++++- src/plugins/apache.sml | 82 ++++++++++++++++++++++++++++++++++++++++++ tests/testApache.dtl | 17 ++++++++- 5 files changed, 157 insertions(+), 2 deletions(-) create mode 100644 lib/apache_auth.dtl diff --git a/lib/apache_auth.dtl b/lib/apache_auth.dtl new file mode 100644 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 the + Apache documentation.}} + +extern val authName : no_newlines -> [Location]; +{{See the + Apache documentation.}} + +extern val authUserFile : your_path -> [Location]; +{{See the + Apache documentation.}} + +extern val requireValidUser : [Location]; +extern val requireUser : [user] -> [Location]; +extern val requireGroup : [group] -> [Location]; +{{See the + Apache documentation.}} + +extern val orderAllowDeny : [Location]; +extern val orderDenyAllow : [Location]; +{{See the + Apache documentation.}} + +extern val allowFromAll : [Location]; +extern val allowFrom : [no_spaces] -> [Location]; +{{See the + Apache documentation.}} + +extern val denyFromAll : [Location]; +extern val denyFrom : [no_spaces] -> [Location]; +{{See the + Apache documentation.}} + +extern val satisfyAll : [Location]; +extern val satisfyAny : [Location]; +{{See the + Apache documentation.}} diff --git a/lib/domain.dtl b/lib/domain.dtl index 34b6859..69b0f5e 100644 --- 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 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}} diff --git a/src/domain.sml b/src/domain.sml index 224755f..4b4042f 100644 --- 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 - 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 +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))) @@ -109,6 +113,14 @@ val _ = Env.type_one "your_domain_host" 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 diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml index 4887043..7689860 100644 --- a/src/plugins/apache.sml +++ b/src/plugins/apache.sml @@ -378,4 +378,86 @@ val () = Env.action_one "serverAlias" 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 diff --git a/tests/testApache.dtl b/tests/testApache.dtl index 9c28fcd..acade80 100644 --- 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"] - 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 -- 2.20.1