changeset 1349:87156c44824f

Periodic tasks
author Adam Chlipala <adam@chlipala.net>
date Sat, 18 Dec 2010 15:17:09 -0500
parents 8a169fc0838b
children a6d421812b93
files doc/manual.tex include/types.h include/urweb.h lib/ur/basis.urs src/c/request.c src/c/urweb.c src/cjr.sml src/cjr_print.sml src/cjrize.sml tests/periodic.ur
diffstat 10 files changed, 115 insertions(+), 10 deletions(-) [+]
line wrap: on
line diff
--- a/doc/manual.tex	Sat Dec 18 14:17:45 2010 -0500
+++ b/doc/manual.tex	Sat Dec 18 15:17:09 2010 -0500
@@ -2100,15 +2100,17 @@
 $$\begin{array}{l}
 \mt{con} \; \mt{task\_kind} :: \mt{Type} \to \mt{Type} \\
 \mt{val} \; \mt{initialize} : \mt{task\_kind} \; \mt{unit} \\
-\mt{val} \; \mt{clientLeaves} : \mt{task\_kind} \; \mt{client}
+\mt{val} \; \mt{clientLeaves} : \mt{task\_kind} \; \mt{client} \\
+\mt{val} \; \mt{periodic} : \mt{int} \to \mt{task\_kind} \; \mt{unit}
 \end{array}$$
 
 A task kind names a particular extension point of generated applications, where the type parameter of a task kind describes which extra input data is available at that extension point.  Add task code with the special declaration form $\mt{task} \; e_1 = e_2$, where $e_1$ is a task kind with data $\tau$, and $e_2$ is a function from $\tau$ to $\mt{transaction} \; \mt{unit}$.
 
 The currently supported task kinds are:
 \begin{itemize}
-\item $\mt{initialize}$: Code that is run in each freshly-allocated request context.
+\item $\mt{initialize}$: Code that is run when the application starts up.
 \item $\mt{clientLeaves}$: Code that is run for each client that the runtime system decides has surfed away.  When a request that generates a new client handle is aborted, that handle will still eventually be passed to $\mt{clientLeaves}$ task code, even though the corresponding browser was never informed of the client handle's existence.  In other words, in general, $\mt{clientLeaves}$ handlers will be called more times than there are actual clients.
+\item $\mt{periodic} \; n$: Code that is run when the application starts up and then every $n$ seconds thereafter.
 \end{itemize}
 
 
--- a/include/types.h	Sat Dec 18 14:17:45 2010 -0500
+++ b/include/types.h	Sat Dec 18 15:17:09 2010 -0500
@@ -59,6 +59,11 @@
 typedef void (*uw_logger)(void*, const char *fmt, ...);
 
 typedef struct {
+  void (*callback)(uw_context);
+  unsigned int period;
+} uw_periodic;
+
+typedef struct {
   int inputs_len, timeout;
   char *url_prefix;
 
@@ -80,6 +85,8 @@
   int (*check_mime)(const char *);
 
   void (*on_error)(uw_context, char *);
+
+  uw_periodic *periodics; // 0-terminated array
 } uw_app;
 
 #define ERROR_BUF_LEN 1024
--- a/include/urweb.h	Sat Dec 18 14:17:45 2010 -0500
+++ b/include/urweb.h	Sat Dec 18 15:17:09 2010 -0500
@@ -293,4 +293,6 @@
 
 extern int uw_time_max, uw_supports_direct_status, uw_min_heap;
 
+failure_kind uw_runCallback(uw_context, void (*callback)(uw_context));
+
 #endif
--- a/lib/ur/basis.urs	Sat Dec 18 14:17:45 2010 -0500
+++ b/lib/ur/basis.urs	Sat Dec 18 15:17:09 2010 -0500
@@ -813,6 +813,7 @@
 con task_kind :: Type -> Type
 val initialize : task_kind unit
 val clientLeaves : task_kind client
+val periodic : int -> task_kind unit
 
 
 (** Information flow security *)
--- a/src/c/request.c	Sat Dec 18 14:17:45 2010 -0500
+++ b/src/c/request.c	Sat Dec 18 15:17:09 2010 -0500
@@ -79,9 +79,44 @@
   return NULL;
 }
 
+typedef struct {
+  uw_app *app;
+  void *logger_data;
+  uw_logger log_error, log_debug;
+} loggers;
+
+typedef struct {
+  loggers *ls;
+  uw_periodic pdic;
+} periodic;
+
+static void *periodic_loop(void *data) {
+  periodic *p = (periodic *)data;
+  uw_context ctx = uw_request_new_context(p->ls->app, p->ls->logger_data, p->ls->log_error, p->ls->log_debug);
+
+  if (!ctx)
+    exit(1);
+
+  while (1) {
+    failure_kind r;
+    do {
+      r = uw_runCallback(ctx, p->pdic.callback);
+    } while (r == UNLIMITED_RETRY);
+
+    sleep(p->pdic.period);
+  };
+}
+
 void uw_request_init(uw_app *app, void *logger_data, uw_logger log_error, uw_logger log_debug) {
   uw_context ctx;
   failure_kind fk;
+  uw_periodic *ps;
+  loggers *ls = malloc(sizeof(loggers));
+
+  ls->app = app;
+  ls->logger_data = logger_data;
+  ls->log_error = log_error;
+  ls->log_debug = log_debug;
 
   uw_global_init();
   uw_app_init(app);
@@ -113,6 +148,18 @@
   }
 
   uw_free(ctx);
+
+  for (ps = app->periodics; ps->callback; ++ps) {
+    pthread_t thread;
+    periodic *arg = malloc(sizeof(periodic));
+    arg->ls = ls;
+    arg->pdic = *ps;
+    
+    if (pthread_create(&thread, NULL, periodic_loop, arg)) {
+      fprintf(stderr, "Error creating periodic thread\n");
+      exit(1);
+    }
+  }  
 }
 
 
@@ -468,12 +515,6 @@
   }
 }
 
-typedef struct {
-  uw_app *app;
-  void *logger_data;
-  uw_logger log_error, log_debug;
-} loggers;
-
 void *client_pruner(void *data) {
   loggers *ls = (loggers *)data;
   uw_context ctx = uw_request_new_context(ls->app, ls->logger_data, ls->log_error, ls->log_debug);
--- a/src/c/urweb.c	Sat Dec 18 14:17:45 2010 -0500
+++ b/src/c/urweb.c	Sat Dec 18 15:17:09 2010 -0500
@@ -3492,3 +3492,19 @@
   else
     uw_error(ctx, FATAL, "Asked for POST body when none exists");
 }
+
+failure_kind uw_runCallback(uw_context ctx, void (*callback)(uw_context)) {
+  int r = setjmp(ctx->jmp_buf);
+
+  if (ctx->app->db_begin(ctx))
+    uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN");
+
+  if (r == 0) {
+    callback(ctx);
+    uw_commit(ctx);
+  }
+  else
+    uw_rollback(ctx, 0);
+
+  return r;
+}
--- a/src/cjr.sml	Sat Dec 18 14:17:45 2010 -0500
+++ b/src/cjr.sml	Sat Dec 18 15:17:09 2010 -0500
@@ -103,7 +103,7 @@
 
 withtype exp = exp' located
 
-datatype task = Initialize | ClientLeaves
+datatype task = Initialize | ClientLeaves | Periodic of Int64.int
 
 datatype decl' =
          DStruct of int * (string * typ) list
--- a/src/cjr_print.sml	Sat Dec 18 14:17:45 2010 -0500
+++ b/src/cjr_print.sml	Sat Dec 18 15:17:09 2010 -0500
@@ -2796,6 +2796,7 @@
 
         val initializers = List.mapPartial (fn (DTask (Initialize, x1, x2, e), _) => SOME (x1, x2, e) | _ => NONE) ds
         val expungers = List.mapPartial (fn (DTask (ClientLeaves, x1, x2, e), _) => SOME (x1, x2, e) | _ => NONE) ds
+        val periodics = List.mapPartial (fn (DTask (Periodic n, x1, x2, e), _) => SOME (n, x1, x2, e) | _ => NONE) ds
 
         val onError = ListUtil.search (fn (DOnError n, _) => SOME n | _ => NONE) ds
 
@@ -2887,6 +2888,36 @@
              newline,
              newline,
 
+             box (ListUtil.mapi (fn (i, (_, x1, x2, e)) =>
+                                    box [string "static void uw_periodic",
+                                         string (Int.toString i),
+                                         string "(uw_context ctx) {",
+                                         newline,
+                                         box [string "uw_unit __uwr_",
+                                              string x1,
+                                              string "_0 = uw_unit_v, __uwr_",
+                                              string x2,
+                                              string "_1 = uw_unit_v;",
+                                              newline,
+                                              p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e,
+                                              string ";",
+                                              newline],
+                                         string "}",
+                                         newline,
+                                         newline]) periodics),
+
+             string "static uw_periodic my_periodics[] = {",
+             box (ListUtil.mapi (fn (i, (n, _, _, _)) =>
+                                    box [string "{uw_periodic",
+                                         string (Int.toString i),
+                                         string ",",
+                                         space,
+                                         string (Int64.toString n),
+                                         string "},"]) periodics),
+             string "{NULL}};",
+             newline,
+             newline,
+
              string "static const char begin_xhtml[] = \"<?xml version=\\\"1.0\\\" encoding=\\\"utf-8\\\" ?>\\n<!DOCTYPE html PUBLIC \\\"-//W3C//DTD XHTML 1.0 Transitional//EN\\\" \\\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\\\">\\n<html xmlns=\\\"http://www.w3.org/1999/xhtml\\\" xml:lang=\\\"en\\\" lang=\\\"en\\\">\";",
              newline,
              newline,
@@ -3043,7 +3074,7 @@
                          "uw_db_init", "uw_db_begin", "uw_db_commit", "uw_db_rollback", "uw_db_close",
                          "uw_handle",
                          "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime",
-                         case onError of NONE => "NULL" | SOME _ => "uw_onError"],
+                         case onError of NONE => "NULL" | SOME _ => "uw_onError", "my_periodics"],
              string "};",
              newline]
     end
--- a/src/cjrize.sml	Sat Dec 18 14:17:45 2010 -0500
+++ b/src/cjrize.sml	Sat Dec 18 15:17:09 2010 -0500
@@ -667,6 +667,7 @@
                  val tk = case #1 e1 of
                               L.EFfi ("Basis", "initialize") => L'.Initialize
                             | L.EFfi ("Basis", "clientLeaves") => L'.ClientLeaves
+                            | L.EFfiApp ("Basis", "periodic", [(L.EPrim (Prim.Int n), _)]) => L'.Periodic n
                             | _ => (ErrorMsg.errorAt loc "Task kind not fully determined";
                                     L'.Initialize)
                  val (e, sm) = cifyExp (e, sm)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/periodic.ur	Sat Dec 18 15:17:09 2010 -0500
@@ -0,0 +1,4 @@
+task periodic 5 = fn () => debug "Every 5 seconds"
+task periodic 13 = fn () => debug "Every 13 seconds"
+
+fun main () : transaction page = return <xml/>