safeGet

8 files changed, 40 insertions, 8 deletions

diff --git a/CHANGELOG b/CHANGELOG
index 5f83e495..58ecd03d 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,4 +1,10 @@
 ========
+Next
+========
+
+- safeGet .urp directive
+
+========
 20100213
 ========
 
diff --git a/doc/manual.tex b/doc/manual.tex
index d9d40919..6d2324db 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -151,6 +151,7 @@ Here is the complete list of directive forms.  ``FFI'' stands for ``foreign func
 \item \texttt{prefix PREFIX} sets the prefix included before every URI within the generated application.  The default is \texttt{/}.
 \item \texttt{profile} generates an executable that may be used with gprof.
 \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{safeGet URI} asks to allow the page handler assigned this canonical URI prefix to cause persistent side effects, even if accessed via an HTTP \cd{GET} request.
 \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.
diff --git a/src/compiler.sig b/src/compiler.sig
index 6be2b22f..0516d97e 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2009, Adam Chlipala
+(* Copyright (c) 2008-2010, Adam Chlipala
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
@@ -53,7 +53,8 @@ signature COMPILER = sig
          filterMime : Settings.rule list,
          protocol : string option,
          dbms : string option,
-         sigFile : string option
+         sigFile : string option,
+         safeGets : string list
     }
     val compile : string -> bool
     val compiler : string -> unit
diff --git a/src/compiler.sml b/src/compiler.sml
index 237cad08..5a97f13d 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -57,7 +57,8 @@ type job = {
      filterMime : Settings.rule list,
      protocol : string option,
      dbms : string option,
-     sigFile : string option
+     sigFile : string option,
+     safeGets : string list
 }
 
 type ('src, 'dst) phase = {
@@ -385,6 +386,7 @@ fun parseUrp' accLibs fname =
                 val protocol = ref NONE
                 val dbms = ref NONE
                 val sigFile = ref (Settings.getSigFile ())
+                val safeGets = ref []
 
                 fun finish sources =
                     let
@@ -413,7 +415,8 @@ fun parseUrp' accLibs fname =
                             sources = sources,
                             protocol = !protocol,
                             dbms = !dbms,
-                            sigFile = !sigFile
+                            sigFile = !sigFile,
+                            safeGets = rev (!safeGets)
                         }
 
                         fun mergeO f (old, new) =
@@ -456,7 +459,8 @@ fun parseUrp' accLibs fname =
                                                     (#sources old),
                             protocol = mergeO #2 (#protocol old, #protocol new),
                             dbms = mergeO #2 (#dbms old, #dbms new),
-                            sigFile = mergeO #2 (#sigFile old, #sigFile new)
+                            sigFile = mergeO #2 (#sigFile old, #sigFile new),
+                            safeGets = #safeGets old @ #safeGets new
                         }
                     in
                         if accLibs then
@@ -569,7 +573,7 @@ fun parseUrp' accLibs fname =
                               | "include" => headers := relifyA arg :: !headers
                               | "script" => scripts := arg :: !scripts
                               | "clientToServer" => clientToServer := ffiS () :: !clientToServer
-                              | "effectful" => effectful := ffiS () :: !effectful
+                              | "safeGet" => safeGets := arg :: !safeGets
                               | "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful
                               | "clientOnly" => clientOnly := ffiS () :: !clientOnly
                               | "serverOnly" => serverOnly := ffiS () :: !serverOnly
@@ -642,6 +646,7 @@ fun parseUrp' accLibs fname =
                 Settings.setMimeRules (#filterMime job);
                 Option.app Settings.setProtocol (#protocol job);
                 Option.app Settings.setDbms (#dbms job);
+                Settings.setSafeGets (#safeGets job);
                 job
             end
     in
diff --git a/src/demo.sml b/src/demo.sml
index 6ae64264..a67411de 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -114,7 +114,8 @@ fun make' {prefix, dirname, guided} =
             filterMime = #filterMime combined @ #filterMime urp,
             protocol = mergeWith #2 (#protocol combined, #protocol urp),
             dbms = mergeWith #2 (#dbms combined, #dbms urp),
-            sigFile = mergeWith #2 (#sigFile combined, #sigFile urp)
+            sigFile = mergeWith #2 (#sigFile combined, #sigFile urp),
+            safeGets = []
         }
 
         val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp")
diff --git a/src/effectize.sml b/src/effectize.sml
index 1685fbe9..7f148476 100644
--- a/src/effectize.sml
+++ b/src/effectize.sml
@@ -143,7 +143,12 @@ fun effectize file =
               | DExport (Link, n, _) =>
                 (case IM.find (writers, n) of
                      NONE => ()
-                   | SOME (loc, s) => ErrorMsg.errorAt loc ("A link (" ^ s ^ ") could cause side effects; try implementing it with a form instead");
+                   | SOME (loc, s) =>
+                     if Settings.isSafeGet s then
+                         ()
+                     else
+                         ErrorMsg.errorAt loc ("A link (" ^ s
+                                               ^ ") could cause side effects; try implementing it with a form instead");
                  ((DExport (Link, n, IM.inDomain (pushers, n)), #2 d), evs))
               | DExport (Action _, n, _) =>
                 ((DExport (Action (if IM.inDomain (writers, n) then
diff --git a/src/settings.sig b/src/settings.sig
index 3179c229..94472eb1 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -198,4 +198,8 @@ signature SETTINGS = sig
     val setSigFile : string option -> unit
     val getSigFile : unit -> string option
 
+    (* Which GET-able functions should be allowed to have side effects? *)
+    val setSafeGets : string list -> unit
+    val isSafeGet : string -> bool
+
 end
diff --git a/src/settings.sml b/src/settings.sml
index cd081725..97c16675 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -452,4 +452,13 @@ val sigFile = ref (NONE : string option)
 fun setSigFile v = sigFile := v
 fun getSigFile () = !sigFile
 
+structure SS = BinarySetFn(struct
+                           type ord_key = string
+                           val compare = String.compare
+                           end)
+
+val safeGet = ref SS.empty
+fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls)
+fun isSafeGet x = SS.member (!safeGet, x)
+
 end