sigfile directive

12 files changed, 87 insertions, 11 deletions

diff --git a/doc/manual.tex b/doc/manual.tex
index 1e5980ba..b6dddad6 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -152,6 +152,7 @@ Here is the complete list of directive forms.  ``FFI'' stands for ``foreign func
 \item \texttt{rewrite KIND FROM TO} gives a rule for rewriting canonical module paths.  For instance, the canonical path of a page may be \texttt{Mod1.Mod2.mypage}, while you would rather the page were accessed via a URL containing only \texttt{page}.  The directive \texttt{rewrite url Mod1/Mod2/mypage page} would accomplish that.  The possible values of \texttt{KIND} determine which kinds of objects are affected.  The kind \texttt{all} matches any object, and \texttt{url} matches page URLs.  The kinds \texttt{table}, \texttt{sequence}, and \texttt{view} match those sorts of SQL entities, and \texttt{relation} matches any of those three.  \texttt{cookie} matches HTTP cookies, and \texttt{style} matches CSS class names.  If \texttt{FROM} ends in \texttt{/*}, it is interpreted as a prefix matching rule, and rewriting occurs by replacing only the appropriate prefix of a path with \texttt{TO}.  While the actual external names of relations and styles have parts separated by underscores instead of slashes, all rewrite rules must be written in terms of slashes.
 \item \texttt{script URL} adds \texttt{URL} to the list of extra JavaScript files to be included at the beginning of any page that uses JavaScript.  This is most useful for importing JavaScript versions of functions found in new FFI modules.
 \item \texttt{serverOnly Module.ident} registers an FFI function or transaction that may only be run on the server.
+\item \texttt{sigfile PATH} sets a path where your application should look for a key to use in cryptographic signing.  This is used to prevent cross-site request forgery attacks for any form handler that both reads a cookie and creates side effects.  If the referenced file doesn't exist, an application will create it and read its saved data on future invocations.  You can also initialize the file manually with any contents at least 16 bytes long; the first 16 bytes will be treated as the key.
 \item \texttt{sql FILENAME} sets where to write an SQL file with the commands to create the expected database schema.  The default is not to create such a file.
 \item \texttt{timeout N} sets to \texttt{N} seconds the amount of time that the generated server will wait after the last contact from a client before determining that that client has exited the application.  Clients that remain active will take the timeout setting into account in determining how often to ping the server, so it only makes sense to set a high timeout to cope with browser and network delays and failures.  Higher timeouts can lead to more unnecessary client information taking up memory on the server.  The timeout goes unused by any page that doesn't involve the \texttt{recv} function, since the server only needs to store per-client information for clients that receive asynchronous messages.
 \end{itemize}
@@ -233,6 +234,8 @@ prefix /dir/script.exe/
 
     To access the \texttt{foo} function in the \texttt{Bar} module, you would then hit \texttt{http://somewhere/dir/script.exe/Bar/foo}.
 
+    If your application contains form handlers that read cookies before causing side effects, then you will need to use the \texttt{sigfile} \texttt{.urp} directive, too.
+
   \item \texttt{fastcgi}: This is a newer protocol inspired by CGI, wherein web servers can start and reuse persistent external processes to generate dynamic content.  Ur/Web doesn't implement the whole protocol, but Ur/Web's support has been tested to work with the \texttt{mod\_fastcgi}s of Apache and lighttpd.
 
     To configure a FastCGI program with Apache, one could combine the above \texttt{ScriptAlias} line with a line like this:
@@ -260,6 +263,8 @@ fastcgi.server = (
 
 \item \texttt{-root Name PATH}: Trigger an alternate module convention for all source files found in directory \texttt{PATH} or any of its subdirectories.  Any file \texttt{PATH/foo.ur} defines a module \texttt{Name.Foo} instead of the usual \texttt{Foo}.  Any file \texttt{PATH/subdir/foo.ur} defines a module \texttt{Name.Subdir.Foo}, and so on for arbitrary nesting of subdirectories.
 
+\item \texttt{-sigfile PATH}: Same as the \texttt{sigfile} directive in \texttt{.urp} files
+
 \item \texttt{-sql FILENAME}: Set where a database set-up SQL script is written.
 
 \item \texttt{-static}: Link the runtime system statically.  The default is to link against dynamic libraries.
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 7d0a95b2..7821a999 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -330,6 +330,7 @@ static void client_send(client *c, buf *msg) {
 
 // Global entry points
 
+extern void uw_global_custom();
 extern void uw_init_crypto();
 
 void uw_global_init() {
@@ -337,6 +338,7 @@ void uw_global_init() {
 
   clients = malloc(0);
 
+  uw_global_custom();
   uw_init_crypto();
 }
 
diff --git a/src/cgi.sml b/src/cgi.sml
index f4426a70..9099d429 100644
--- a/src/cgi.sml
+++ b/src/cgi.sml
@@ -28,11 +28,24 @@
 structure Cgi :> CGI = struct
 
 open Settings
+open Print.PD Print
 
 val () = addProtocol {name = "cgi",
                       compile = "",
                       linkStatic = Config.lib ^ "/../liburweb_cgi.a",
                       linkDynamic = "-lurweb_cgi",
-                      persistent = false}
+                      persistent = false,
+                      code = fn () => box [string "void uw_global_custom() {",
+                                           newline,
+                                           case getSigFile () of
+                                               NONE => box []
+                                             | SOME sf => box [string "extern char *uw_sig_file;",
+                                                               newline,
+                                                               string "uw_sig_file = \"",
+                                                               string sf,
+                                                               string "\";",
+                                                               newline],
+                                           string "}",
+                                           newline]}
 
 end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 360ecb5c..fae01db1 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2805,6 +2805,8 @@ fun p_file env (ds, ps) =
              newline,
              newline,
 
+             #code (Settings.currentProtocol ()) (),
+
              if hasDb then
                  #init (Settings.currentDbms ()) {dbstring = !dbstring,
                                                   prepared = !prepped,
diff --git a/src/compiler.sig b/src/compiler.sig
index fd1eccf8..78e82ba8 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -51,7 +51,8 @@ signature COMPILER = sig
          filterUrl : Settings.rule list,
          filterMime : Settings.rule list,
          protocol : string option,
-         dbms : string option
+         dbms : string option,
+         sigFile : string option
     }
     val compile : string -> bool
     val compiler : string -> unit
diff --git a/src/compiler.sml b/src/compiler.sml
index ba80e37e..99c730f1 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -55,7 +55,8 @@ type job = {
      filterUrl : Settings.rule list,
      filterMime : Settings.rule list,
      protocol : string option,
-     dbms : string option
+     dbms : string option,
+     sigFile : string option
 }
 
 type ('src, 'dst) phase = {
@@ -379,6 +380,7 @@ fun parseUrp' accLibs fname =
                 val libs = ref []
                 val protocol = ref NONE
                 val dbms = ref NONE
+                val sigFile = ref (Settings.getSigFile ())
 
                 fun finish sources =
                     let
@@ -405,7 +407,8 @@ fun parseUrp' accLibs fname =
                             filterMime = rev (!mime),
                             sources = sources,
                             protocol = !protocol,
-                            dbms = !dbms
+                            dbms = !dbms,
+                            sigFile = !sigFile
                         }
 
                         fun mergeO f (old, new) =
@@ -446,7 +449,8 @@ fun parseUrp' accLibs fname =
                                       @ List.filter (fn s => List.all (fn s' => s' <> s) (#sources new))
                                                     (#sources old),
                             protocol = mergeO #2 (#protocol old, #protocol new),
-                            dbms = mergeO #2 (#dbms old, #dbms new)
+                            dbms = mergeO #2 (#dbms old, #dbms new),
+                            sigFile = mergeO #2 (#sigFile old, #sigFile new)
                         }
                     in
                         if accLibs then
@@ -523,6 +527,14 @@ fun parseUrp' accLibs fname =
                                 (case !database of
                                      NONE => database := SOME arg
                                    | SOME _ => ())
+                              | "dbms" =>
+                                (case !dbms of
+                                     NONE => dbms := SOME arg
+                                   | SOME _ => ())
+                              | "sigfile" =>
+                                (case !sigFile of
+                                     NONE => sigFile := SOME arg
+                                   | SOME _ => ())
                               | "exe" =>
                                 (case !exe of
                                      NONE => exe := SOME (relify arg)
diff --git a/src/demo.sml b/src/demo.sml
index bb79a749..6280400b 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -112,7 +112,8 @@ fun make' {prefix, dirname, guided} =
             filterUrl = #filterUrl combined @ #filterUrl urp,
             filterMime = #filterMime combined @ #filterMime urp,
             protocol = mergeWith #2 (#protocol combined, #protocol urp),
-            dbms = mergeWith #2 (#dbms combined, #dbms urp)
+            dbms = mergeWith #2 (#dbms combined, #dbms urp),
+            sigFile = mergeWith #2 (#sigFile combined, #sigFile urp)
         }
 
         val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp")
diff --git a/src/fastcgi.sml b/src/fastcgi.sml
index c2e81d92..31feaee9 100644
--- a/src/fastcgi.sml
+++ b/src/fastcgi.sml
@@ -28,11 +28,24 @@
 structure Fastcgi :> FASTCGI = struct
 
 open Settings
+open Print.PD Print
 
 val () = addProtocol {name = "fastcgi",
                       compile = "",
                       linkStatic = Config.lib ^ "/../liburweb_fastcgi.a",
                       linkDynamic = "-lurweb_fastcgi",
-                      persistent = true}
+                      persistent = true,
+                      code = fn () => box [string "void uw_global_custom() {",
+                                           newline,
+                                           case getSigFile () of
+                                               NONE => box []
+                                             | SOME sf => box [string "extern char *uw_sig_file;",
+                                                               newline,
+                                                               string "uw_sig_file = \"",
+                                                               string sf,
+                                                               string "\";",
+                                                               newline],
+                                           string "}",
+                                           newline]}
 
 end
diff --git a/src/http.sml b/src/http.sml
index 4054eb1e..a760e195 100644
--- a/src/http.sml
+++ b/src/http.sml
@@ -28,12 +28,26 @@
 structure Http :> HTTP = struct
 
 open Settings
+open Print.PD Print
 
 val () = addProtocol {name = "http",
                       compile = "",
                       linkStatic = Config.lib ^ "/../liburweb_http.a",
                       linkDynamic = "-lurweb_http",
-                      persistent = true}
+                      persistent = true,
+                      code = fn () => box [string "void uw_global_custom() {",
+                                           newline,
+                                           case getSigFile () of
+                                               NONE => box []
+                                             | SOME sf => box [string "extern char *uw_sig_file;",
+                                                               newline,
+                                                               string "uw_sig_file = \"",
+                                                               string sf,
+                                                               string "\";",
+                                                               newline],
+                                           string "}",
+                                           newline]}
+
 val () = setProtocol "http"
 
 end
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index 9cf5064a..fc1ba7e5 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -72,6 +72,9 @@ fun doArgs args =
       | "-root" :: name :: root :: rest =>
         (Compiler.addModuleRoot (root, name);
          doArgs rest)
+      | "-sigfile" :: name :: rest =>
+        (Settings.setSigFile (SOME name);
+         doArgs rest)
       | arg :: rest =>
         (if size arg > 0 andalso String.sub (arg, 0) = #"-" then
              raise Fail ("Unknown flag " ^ arg)
diff --git a/src/settings.sig b/src/settings.sig
index f3a4379e..348c47d4 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -96,7 +96,8 @@ signature SETTINGS = sig
         compile : string,    (* Pass these `gcc -c' arguments *)
         linkStatic : string, (* Pass these static linker arguments *)
         linkDynamic : string,(* Pass these dynamic linker arguments *)
-        persistent : bool    (* Multiple requests per process? *)
+        persistent : bool,   (* Multiple requests per process? *)
+        code : unit -> Print.PD.pp_desc (* Extra code to include in C files *)
     }
     val addProtocol : protocol -> unit
     val setProtocol : string -> unit
@@ -190,4 +191,7 @@ signature SETTINGS = sig
     val setDeadlines : bool -> unit
     val getDeadlines : unit -> bool
 
+    val setSigFile : string option -> unit
+    val getSigFile : unit -> string option
+
 end
diff --git a/src/settings.sml b/src/settings.sml
index 0bbe3961..f600d2ac 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -275,7 +275,8 @@ type protocol = {
      compile : string,
      linkStatic : string,
      linkDynamic : string,
-     persistent : bool
+     persistent : bool,
+     code : unit -> Print.PD.pp_desc
 }
 val protocols = ref ([] : protocol list)
 fun addProtocol p = protocols := p :: !protocols
@@ -288,7 +289,8 @@ val curProto = ref {name = "",
                     compile = "",
                     linkStatic = "",
                     linkDynamic = "",
-                    persistent = false}
+                    persistent = false,
+                    code = fn () => Print.box []}
 fun setProtocol name =
     case getProtocol name of
         NONE => raise Fail ("Unknown protocol " ^ name)
@@ -441,4 +443,8 @@ val deadlines = ref false
 fun setDeadlines b = deadlines := b
 fun getDeadlines () = !deadlines
 
+val sigFile = ref (NONE : string option)
+fun setSigFile v = sigFile := v
+fun getSigFile () = !sigFile
+
 end