Some mod_expires support

diff --git a/lib/mod_expires.dtl b/lib/mod_expires.dtl
new file mode 100644 (file)
index 0000000..649fca4
--- /dev/null
+++ b/lib/mod_expires.dtl
@@ -0,0 +1,20 @@
+{{Support for Apache's mod_expires}}
+
+extern type mime_type;
+
+extern type interval_base;
+extern val access : interval_base;
+extern val modification : interval_base;
+
+extern type interval;
+extern val years : interval;
+extern val months : interval;
+extern val weeks : interval;
+extern val days : interval;
+extern val hours : interval;
+extern val minutes : interval;
+extern val seconds : interval;
+
+extern val expiresByType : mime_type -> interval_base -> int -> interval -> [^Vhost];
+{{See <a href="http://httpd.apache.org/docs/2.0/mod/mod_expires.html#expiresbytype">
+  Apache documentation</a>.}}

diff --git a/src/domain.sml b/src/domain.sml
index 63b039c..ffa03c4 100644 (file)
--- a/src/domain.sml
+++ b/src/domain.sml
@@ -235,6 +235,10 @@ val _ = Env.type_one "node"
        Env.string
        validNode
 
        Env.string
        validNode
 

+val _ = Env.type_one "mime_type"
+       Env.string
+       (CharVector.exists (fn ch => ch = #"/"))
+

 val _ = Env.registerFunction ("your_ip_to_ip",
                              fn [e] => SOME e
                               | _ => NONE)
 val _ = Env.registerFunction ("your_ip_to_ip",
                              fn [e] => SOME e
                               | _ => NONE)

diff --git a/src/env.sig b/src/env.sig
index 0a50620..8e5962c 100644 (file)
--- a/src/env.sig
+++ b/src/env.sig
@@ -73,6 +73,9 @@ signature ENV = sig
     val action_three : string
                       -> string * 'a arg * string * 'b arg * string * 'c arg
                       -> ('a * 'b * 'c -> unit) -> unit
     val action_three : string
                       -> string * 'a arg * string * 'b arg * string * 'c arg
                       -> ('a * 'b * 'c -> unit) -> unit

+    val action_four : string
+                      -> string * 'a arg * string * 'b arg * string * 'c arg * string * 'd arg
+                      -> ('a * 'b * 'c * 'd -> unit) -> unit

 
     val actionV_none : string -> (env_vars -> unit) -> unit
     val actionV_one : string -> string * 'a arg -> (env_vars * 'a -> unit) -> unit
 
     val actionV_none : string -> (env_vars -> unit) -> unit
     val actionV_one : string -> string * 'a arg -> (env_vars * 'a -> unit) -> unit

diff --git a/src/env.sml b/src/env.sml
index ef710c1..8ebcaf4 100644 (file)
--- a/src/env.sml
+++ b/src/env.sml
@@ -149,6 +149,16 @@ fun three func (name1, arg1, name2, arg2, name3, arg3) f (_, [e1, e2, e3]) =
                                         SM.empty))
   | three func _ _ (_, es) = badArgs (func, es)
 
                                         SM.empty))
   | three func _ _ (_, es) = badArgs (func, es)
 

+fun four func (name1, arg1, name2, arg2, name3, arg3, name4, arg4) f (_, [e1, e2, e3, e4]) =
+    (case (arg1 e1, arg2 e2, arg3 e3, arg4 e4) of
+        (NONE, _, _, _) => badArg (func, name1, e1)
+       | (_, NONE, _, _) => badArg (func, name2, e2)
+       | (_, _, NONE, _) => badArg (func, name3, e3)
+       | (_, _, _, NONE) => badArg (func, name4, e4)
+       | (SOME v1, SOME v2, SOME v3, SOME v4) => (f (v1, v2, v3, v4);
+                                                 SM.empty))
+  | four func _ _ (_, es) = badArgs (func, es)
+

 fun noneV func f (evs, []) = (f evs;
                              SM.empty)
   | noneV func _ (_, es) = badArgs (func, es)
 fun noneV func f (evs, []) = (f evs;
                              SM.empty)
   | noneV func _ (_, es) = badArgs (func, es)


@@ -189,6 +199,7 @@ fun action_none name f = registerAction (name, none name f)
 fun action_one name args f = registerAction (name, one name args f)
 fun action_two name args f = registerAction (name, two name args f)
 fun action_three name args f = registerAction (name, three name args f)
 fun action_one name args f = registerAction (name, one name args f)
 fun action_two name args f = registerAction (name, two name args f)
 fun action_three name args f = registerAction (name, three name args f)

+fun action_four name args f = registerAction (name, four name args f)

 
 fun actionV_none name f = registerAction (name, fn (env, _) => (f env; env))
 fun actionV_one name args f = registerAction (name, oneV name args f)
 
 fun actionV_none name f = registerAction (name, fn (env, _) => (f env; env))
 fun actionV_one name args f = registerAction (name, oneV name args f)

diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml
index 0b0b11d..adc579e 100644 (file)
--- a/src/plugins/apache.sml
+++ b/src/plugins/apache.sml
@@ -1,5 +1,5 @@
 (* HCoop Domtool (http://hcoop.sourceforge.net/)
 (* HCoop Domtool (http://hcoop.sourceforge.net/)

- * Copyright (c) 2006-2007, Adam Chlipala
+ * Copyright (c) 2006-2009, Adam Chlipala

  *
  * This program is free software; you can redistribute it and/or
  * modify it under the terms of the GNU General Public License
  *
  * This program is free software; you can redistribute it and/or
  * modify it under the terms of the GNU General Public License


@@ -241,6 +241,19 @@ val autoindex_option = fn (EApp ((EVar "descriptionWidth", _), w), _) =>
 
                        | _ => NONE
 
 
                        | _ => NONE
 

+val interval_base = fn (EVar "access", _) => SOME "access"
+                    | (EVar "modification", _) => SOME "modification"
+                    | _ => NONE
+
+val interval = fn (EVar "years", _) => SOME "years"
+               | (EVar "months", _) => SOME "months"
+               | (EVar "weeks", _) => SOME "weeks"
+               | (EVar "days", _) => SOME "days"
+               | (EVar "hours", _) => SOME "hours"
+               | (EVar "minutes", _) => SOME "minutes"
+               | (EVar "seconds", _) => SOME "seconds"
+               | _ => NONE
+

 val vhostsChanged = ref false
 val logDeleted = ref false
 val delayedLogMoves = ref (fn () => ())
 val vhostsChanged = ref false
 val logDeleted = ref false
 val delayedLogMoves = ref (fn () => ())


@@ -422,6 +435,8 @@ fun write s = app (fn (_, file) => TextIO.output (file, s)) (!vhostFiles)
 
 val rewriteEnabled = ref false
 val localRewriteEnabled = ref false
 
 val rewriteEnabled = ref false
 val localRewriteEnabled = ref false

+val expiresEnabled = ref false
+val localExpiresEnabled = ref false

 val currentVhost = ref ""
 val currentVhostId = ref ""
 val sslEnabled = ref false
 val currentVhost = ref ""
 val currentVhostId = ref ""
 val sslEnabled = ref false


@@ -483,6 +498,8 @@ fun vhostBody (env, makeFullHost) =
 
        rewriteEnabled := false;
        localRewriteEnabled := false;
 
        rewriteEnabled := false;
        localRewriteEnabled := false;

+       expiresEnabled := false;
+       localExpiresEnabled := false;

        vhostFiles := map (fn (node, ip) =>
                              let
                                  val file = Domain.domainFile {node = node,
        vhostFiles := map (fn (node, ip) =>
                              let
                                  val file = Domain.domainFile {node = node,


@@ -585,7 +602,8 @@ val () = Env.container_one "location"
              inLocal := true),
          fn () => (write "\t</Location>\n";
                    inLocal := false;
              inLocal := true),
          fn () => (write "\t</Location>\n";
                    inLocal := false;

-                   localRewriteEnabled := false))
+                   localRewriteEnabled := false;
+                   localExpiresEnabled := false))

 
 val () = Env.container_one "directory"
         ("directory", Env.string)
 
 val () = Env.container_one "directory"
         ("directory", Env.string)


@@ -596,7 +614,8 @@ val () = Env.container_one "directory"
              inLocal := true),
          fn () => (write "\t</Directory>\n";
                    inLocal := false;
              inLocal := true),
          fn () => (write "\t</Directory>\n";
                    inLocal := false;

-                   localRewriteEnabled := false))
+                   localRewriteEnabled := false;
+                   localExpiresEnabled := false))

 
 val () = Env.container_one "filesMatch"
         ("regexp", Env.string)
 
 val () = Env.container_one "filesMatch"
         ("regexp", Env.string)


@@ -605,7 +624,8 @@ val () = Env.container_one "filesMatch"
              write prefix;
              write "\">\n"),
          fn () => (write "\t</FilesMatch>\n";
              write prefix;
              write "\">\n"),
          fn () => (write "\t</FilesMatch>\n";

-                   localRewriteEnabled := false))
+                   localRewriteEnabled := false;
+                   localExpiresEnabled := false))

 
 fun checkRewrite () =
     if !inLocal then
 
 fun checkRewrite () =
     if !inLocal then


@@ -620,6 +640,19 @@ fun checkRewrite () =
        (write "\tRewriteEngine on\n";
         rewriteEnabled := true)
 
        (write "\tRewriteEngine on\n";
         rewriteEnabled := true)
 

+fun checkExpires () =
+    if !inLocal then
+       if !localExpiresEnabled then
+           ()
+       else
+           (write "\tExpiresActive on\n";
+            localExpiresEnabled := true)
+    else if !expiresEnabled then
+       ()
+    else
+       (write "\tExpiresActive on\n";
+        expiresEnabled := true)
+

 val () = Env.action_three "localProxyRewrite"
         ("from", Env.string, "to", Env.string, "port", Env.int)
         (fn (from, to, port) =>
 val () = Env.action_three "localProxyRewrite"
         ("from", Env.string, "to", Env.string, "port", Env.int)
         (fn (from, to, port) =>


@@ -632,6 +665,24 @@ val () = Env.action_three "localProxyRewrite"
              write to;
              write " [P]\n"))
 
              write to;
              write " [P]\n"))
 

+val () = Env.action_four "expiresByType"
+        ("mime", Env.string, "base", interval_base, "num", Env.int, "inter", interval)
+        (fn (mime, base, num, inter) =>
+            (checkExpires ();
+             write "\tExpiresByType\t\"";
+             write mime;
+             write "\"\t\"";
+             write base;
+             write " plus ";
+             if num < 0 then
+                 (write "-";
+                  write (Int.toString (~num)))
+             else
+                 write (Int.toString num);
+             write " ";
+             write inter;
+             write "\"\n"))
+

 val () = Env.action_two "proxyPass"
         ("from", Env.string, "to", Env.string)
         (fn (from, to) =>
 val () = Env.action_two "proxyPass"
         ("from", Env.string, "to", Env.string)
         (fn (from, to) =>