compile when debugging

conf/conf.c

@@ -56,7 +56,7 @@
 #include "conf/conf.h"
 #include "filter/filter.h"
 #include "sysdep/unix/unix.h"
-
+#include "ecl/cldefs.h"
 
 static jmp_buf conf_jmpbuf;
 
@@ -278,6 +278,10 @@ config_do_commit(struct config *c, int type)
   rt_commit(c, old_config);
   DBG("protos_commit\n");
   protos_commit(c, old_config, force_restart, type);
+  DBG("lisp\n");
+  if (c->lisp_load) {
+	  clbird_load(c->lisp_load);
+  }
 
   int obs = 0;
   if (old_config)

conf/conf.h

@@ -30,6 +30,7 @@ struct config {
   const char *syslog_name;		/* Name used for syslog (NULL -> no syslog) */
   struct rtable_config *def_tables[NET_MAX]; /* Default routing tables for each network */
   struct iface_patt *router_id_from;	/* Configured list of router ID iface patterns */
+  const char *lisp_load;		/* Path to Common Lisp source file to load (NULL -> don't load one) */
 
   u32 router_id;			/* Our Router ID */
   u32 proto_default_debug;		/* Default protocol debug mask */

ecl/clbird.lisp

@@ -1,10 +1,13 @@
 (defpackage :bird-impl
   (:use))
 
+(defpackage :bird-filter
+  (:use))
+
 (defpackage :bird
   (:nicknames :b)
   (:use :cl)
-  (:export :version))
+  (:export :version :deffilter))
 
 (in-package :bird)
 
@@ -46,7 +49,6 @@
   (make-instance 'bird-route
                  :ptr ptr))
 
-
 (defclass val-pair (bird-val) ())
 (defclass val-quad (bird-val) ())
 (defclass val-ip (bird-val) ())
@@ -71,7 +73,6 @@
                                :ty ty)))
     (change-class plain cls)))
 
-#+ecl
 (defun maybe-make-bird-val (obj)
   "If OBJ is a foreign pointer, run MAKE-BIRD-VAL on it; otherwise, return OBJ."
   (if (typep obj 'si::foreign-data)
@@ -116,10 +117,11 @@
 
 (defun val~ (val1 val2)
   "Returns T if VAL1 is in the range VAL2 (both BIRD-VALs)."
-  (check-type val1 bird-val)
-  (check-type val2 bird-val)
-  (bird-impl::val-in-range (slot-value val1 'ptr)
-                           (slot-value val2 'ptr)))
+  (when (and val1 val2)
+    (check-type val1 bird-val)
+    (check-type val2 bird-val)
+    (bird-impl::val-in-range (slot-value val1 'ptr)
+                             (slot-value val2 'ptr))))
 
 (defun routing-tables ()
   "Get all of the BIRD routing tables."
@@ -268,5 +270,20 @@
              (gethash id +ea-code-to-keyword+ :unknown)
              (maybe-make-bird-val val))))
 
+(defmacro deffilter (name (route-name) &body body)
+  "Define a BIRD filter called NAME, with syntax similar to DEFUN. The route passed in as ROUTE-NAME is a BIRD-ROUTE object."
+  (let ((name-sym (intern (symbol-name name) 'bird-filter))
+        (rte-csym (gensym))
+        (rte-sym (gensym)))
+    `(let ((,rte-csym nil))
+       (defun ,name-sym (,rte-sym)
+         (let ((,route-name (if ,rte-csym
+                                (progn
+                                  (setf (slot-value ,rte-csym 'bird::ptr) ,rte-sym)
+                                  ,rte-csym)
+                                (setf ,rte-csym (bird::make-route ,rte-sym)))))
+           (block nil
+             ,@body))))))
+
 (eval-when (:load-toplevel)
   (format t "CL bird stuff is going brr!~%"))

ecl/cldefs.h

@@ -39,5 +39,7 @@ cl_object ea_to_object(eattr *e);
 cl_object clbird_get_eattrs(cl_object rte_obj);
 void init_ecl_functions(void);
 void clbird_init(int, char**);
+char* ecl_get_string_for(cl_object obj);
+void clbird_load(char*);
 
 #endif

ecl/ecl.c

@@ -209,7 +209,7 @@ clbird_cidr4(cl_object o1, cl_object o2, cl_object o3, cl_object o4, cl_object l
 	ret |= ecl_to_fix(o3) << 8;
 	ret |= ecl_to_fix(o4);
 	net_addr *na = ecl_alloc(sizeof(net_addr));
-	net_fill_ip4(na, ret, ecl_to_fix(len));
+	net_fill_ip4(na, _MI4(ret), ecl_to_fix(len));
 	struct f_val *res = ecl_alloc(sizeof(struct f_val));
 	res->type = T_NET;
 	res->val.net = na;
@@ -381,3 +381,35 @@ clbird_init(int argc, char **argv)
   ecl_init_module(NULL, clbird_native_lisp_init);
   init_ecl_functions();
 }
+
+char*
+ecl_get_string_for(cl_object obj) {
+	cl_object formatted = NULL;
+	ECL_HANDLER_CASE_BEGIN(ecl_process_env(), ecl_list1(ECL_T)) {
+		formatted = cl_princ_to_string(obj);
+	} ECL_HANDLER_CASE(1, condition) {
+	} ECL_HANDLER_CASE_END;
+	if (formatted == NULL) {
+		return "[error occurred printing Lisp object]";
+	}
+	assert(ECL_STRINGP(formatted));
+	if (!ecl_fits_in_base_string(formatted)) {
+		return "[Unicode error printing Lisp object]";
+	}
+	cl_object base = si_coerce_to_base_string(formatted);
+	char* ret = base->base_string.self;
+	return ret;
+}
+
+void
+clbird_load(char *file)
+{
+	ECL_HANDLER_CASE_BEGIN(ecl_process_env(), ecl_list1(ECL_T)) {
+		log(L_INFO "Loading Lisp: %s", file);
+		cl_load(1, ecls(file));
+		log(L_INFO "Lisp successfully loaded");
+	} ECL_HANDLER_CASE(1, condition) {
+		char* cond_fmt = ecl_get_string_for(condition);
+		log(L_WARN "Failed to load %s: %s", file, cond_fmt);
+	} ECL_HANDLER_CASE_END;
+}

filter/config.Y

@@ -315,9 +315,9 @@ CF_GRAMMAR
 conf: filter_def ;
 filter_def:
    FILTER symbol { $2 = cf_define_symbol($2, SYM_FILTER, filter, NULL); cf_push_scope( $2 ); }
-     filter_body {
+     text {
      struct filter *f = cfg_alloc(sizeof(struct filter));
-     *f = (struct filter) { .sym = $2, .root = $4 };
+     *f = (struct filter) { .sym = $2, .lisp_name = $4 };
      $2->filter = f;
 
      cf_pop_scope();
@@ -431,17 +431,18 @@ filter:
      cf_assert_symbol($1, SYM_FILTER);
      $$ = $1->filter;
    }
- | filter_body {
+ | text {
      struct filter *f = cfg_alloc(sizeof(struct filter));
-     *f = (struct filter) { .root = $1 };
+     *f = (struct filter) { .lisp_name = $1 };
      $$ = f;
    }
  ;
 
 where_filter:
-   WHERE term {
-     /* Construct 'IF term THEN { ACCEPT; } ELSE { REJECT; }' */
-     $$ = f_new_where($2);
+   WHERE text {
+     struct filter *f = cfg_alloc(sizeof(struct filter));
+     *f = (struct filter) { .lisp_name = $2 };
+     $$ = f;
    }
  ;
 

filter/f-util.c

@@ -24,22 +24,10 @@ filter_name(const struct filter *filter)
     return "ACCEPT";
   else if (filter == FILTER_REJECT)
     return "REJECT";
-  else if (!filter->sym)
-    return "(unnamed)";
   else
-    return filter->sym->name;
+    return filter->lisp_name;
 }
 
-struct filter *f_new_where(struct f_inst *where)
-{
-  struct f_inst *cond = f_new_inst(FI_CONDITION, where,
-				   f_new_inst(FI_DIE, F_ACCEPT),
-				   f_new_inst(FI_DIE, F_REJECT));
-
-  struct filter *f = cfg_allocz(sizeof(struct filter));
-  f->root = f_linearize(cond);
-  return f;
-}
 
 #define CA_KEY(n)	n->name, n->fda.type
 #define CA_NEXT(n)	n->next

filter/filter.c

@@ -43,6 +43,8 @@
 #include "filter/filter.h"
 #include "filter/f-inst.h"
 #include "filter/data.h"
+#include <ecl/ecl.h>
+#include "ecl/cldefs.h"
 
 
 /* Exception bits */
@@ -272,7 +274,45 @@ f_run(const struct filter *filter, struct rte **rte, struct linpool *tmp_pool, i
     return F_REJECT;
 
   int rte_cow = ((*rte)->flags & REF_COW);
-  DBG( "Running filter `%s'...", filter->name );
+  DBG("Running filter %s...", filter->lisp_name);
+  clock_t begin = clock();
+
+  cl_object package = ecl_find_package("BIRD-FILTER");
+  assert(package != ECL_NIL);
+  cl_object sym = _ecl_intern(filter->lisp_name, package);
+  cl_object result = ECL_NIL;
+
+  cl_env_ptr env = ecl_process_env();
+  int failed = 0;
+  ECL_HANDLER_CASE_BEGIN(env, ecl_list1(ECL_T)) {
+	  cl_object func = cl_symbol_function(sym);
+	  result = cl_funcall(2, func, ecl_make_pointer(*rte));
+  } ECL_HANDLER_CASE(1, condition) {
+	  char* err = ecl_get_string_for(condition);
+	  DBG("failed: %s\n", err);
+	  log_rl(&rl_runtime_err, L_ERR "Error executing Lisp filter %s: %s", filter->lisp_name, err);
+	  failed = 1;
+  } ECL_HANDLER_CASE_END;
+  if (failed) {
+	  return F_ERROR;
+  }
+
+  clock_t end = clock();
+  double time_spent = (double)(end - begin) / CLOCKS_PER_SEC;
+
+  if (ecl_eql(result, eclk("ACCEPT"))) {
+	  DBG("accepted (%fms)\n", time_spent * 1000.0);
+	  return F_ACCEPT;
+  } else if (ecl_eql(result, eclk("REJECT"))) {
+	  DBG("rejected (%fms)\n", time_spent * 1000.0);
+	  return F_REJECT;
+  }
+
+  char* ret = ecl_get_string_for(result);
+  DBG("returned %s (%fms)\n", ret, time_spent * 1000.0);
+  log_rl(&rl_runtime_err, L_ERR "Unexpected return value for Lisp filter %s: %s", filter->lisp_name, ret);
+  return F_ERROR;
+
 
   /* Initialize the filter state */
   filter_state = (struct filter_state) {
@@ -285,7 +325,8 @@ f_run(const struct filter *filter, struct rte **rte, struct linpool *tmp_pool, i
   LOG_BUFFER_INIT(filter_state.buf);
 
   /* Run the interpreter itself */
-  enum filter_return fret = interpret(&filter_state, filter->root, NULL);
+  //enum filter_return fret = interpret(&filter_state, filter->root, NULL);
+  enum filter_return fret = F_ACCEPT;
 
   if (filter_state.old_rta) {
     /*
@@ -432,7 +473,7 @@ filter_same(const struct filter *new, const struct filter *old)
     return 0;
 
   if ((!old->sym) && (!new->sym))
-    return f_same(new->root, old->root);
+    return strcmp(new->lisp_name, old->lisp_name) == 0;
 
   if ((!old->sym) || (!new->sym))
     return 0;
@@ -467,7 +508,7 @@ filter_commit(struct config *new, struct config *old)
       case SYM_FILTER:
 	if ((osym = cf_find_symbol(old, sym->name)) &&
 	    (osym->class == SYM_FILTER) &&
-	    f_same(sym->filter->root, osym->filter->root))
+	    (strcmp(sym->filter->lisp_name, osym->filter->lisp_name) == 0))
 	  sym->flags |= SYM_FLAG_SAME;
 	else
 	  sym->flags &= ~SYM_FLAG_SAME;
@@ -481,8 +522,7 @@ void filters_dump_all(void)
   WALK_LIST(sym, config->symbols) {
     switch (sym->class) {
       case SYM_FILTER:
-	debug("Named filter %s:\n", sym->name);
-	f_dump_line(sym->filter->root, 1);
+	debug("Named filter %s: Lisp function %s\n", sym->name, sym->filter->lisp_name);
 	break;
       case SYM_FUNCTION:
 	debug("Function %s:\n", sym->name);
@@ -505,7 +545,7 @@ void filters_dump_all(void)
 	      debug(" named filter %s\n", c->in_filter->sym->name);
 	    } else {
 	      debug("\n");
-	      f_dump_line(c->in_filter->root, 2);
+	      debug("Lisp function %s\n", c->in_filter->lisp_name);
 	    }
 	  }
 	}

filter/filter.h

@@ -45,8 +45,8 @@ struct f_val;
 /* The filter encapsulating structure to be pointed-to from outside */
 struct f_line;
 struct filter {
-  struct symbol *sym;
-  const struct f_line *root;
+	struct symbol *sym;
+	const char* lisp_name;
 };
 
 struct rte;

nest/cmds.c

@@ -15,6 +15,7 @@
 #include "lib/string.h"
 #include "lib/resource.h"
 #include "filter/filter.h"
+#include "ecl/cldefs.h"
 #include <ecl/ecl.h>
 
 extern int shutting_down;
@@ -110,17 +111,6 @@ cmd_eval(const struct f_line *expr)
 
   cli_msg(23, "%s", buf.start);
 }
-char* ecl_get_string_for(cl_object obj) {
-  // FIXME: handle errors in the printer
-	cl_object formatted = cl_princ_to_string(obj);
-	assert(ECL_STRINGP(formatted));
-	if (!ecl_fits_in_base_string(formatted)) {
-		return NULL; // sad
-	}
-	cl_object base = si_coerce_to_base_string(formatted);
-	char* ret = base->base_string.self;
-	return ret;
-}
 
 void cmd_cl_eval(const char *obj)
 {
@@ -132,19 +122,18 @@ void cmd_cl_eval(const char *obj)
 	}
 
 	cl_object result = ECL_NIL;
+	char* err = NULL;
 	ECL_HANDLER_CASE_BEGIN(env, ecl_list1(ECL_T)) {
 		result = cl_eval(form);
 	} ECL_HANDLER_CASE(1, condition) {
-		char* err = ecl_get_string_for(condition);
-		cli_msg(8041, "runtime error: %s", err ? err : "wat");
-		return;
+		err = ecl_get_string_for(condition);
 	} ECL_HANDLER_CASE_END;
-
-	char* disp = ecl_get_string_for(result);
-	if (!disp) {
-		cli_msg(8043, "unicode what");
+	if (err) {
+		cli_msg(8041, "runtime error: %s", err);
 		return;
 	}
+
+	char* disp = ecl_get_string_for(result);
 	char* newline = "\n";
 	char* line = strtok(disp, newline);
 	while (line != NULL) {

nest/config.Y

@@ -87,7 +87,7 @@ proto_postconfig(void)
 
 CF_DECLS
 
-CF_KEYWORDS(ROUTER, ID, HOSTNAME, PROTOCOL, TEMPLATE, PREFERENCE, DISABLED, DEBUG, ALL, OFF, DIRECT)
+CF_KEYWORDS(ROUTER, ID, HOSTNAME, PROTOCOL, TEMPLATE, PREFERENCE, DISABLED, DEBUG, ALL, OFF, DIRECT, LISP)
 CF_KEYWORDS(INTERFACE, IMPORT, EXPORT, FILTER, NONE, VRF, DEFAULT, TABLE, STATES, ROUTES, FILTERS)
 CF_KEYWORDS(IPV4, IPV6, VPN4, VPN6, ROA4, ROA6, FLOW4, FLOW6, SADR, MPLS)
 CF_KEYWORDS(RECEIVE, LIMIT, ACTION, WARN, BLOCK, RESTART, DISABLE, KEEP, FILTERED)
@@ -151,6 +151,10 @@ idval:
    }
  ;
 
+conf: lisp_load ;
+
+lisp_load: LISP text ';' { new_config->lisp_load = $2; } ;
+
 conf: hostname_override ;
 
 hostname_override: HOSTNAME text ';' { new_config->hostname = $2; } ;

nest/proto.c

@@ -393,6 +393,7 @@ channel_roa_subscribe_filter(struct channel *c, int dir)
   if (c->channel == &channel_bgp)
     valid = dir ? !!c->in_table : !!c->out_table;
 
+  /*
   struct filter_iterator fit;
   FILTER_ITERATE_INIT(&fit, f, c->proto->pool);
 
@@ -419,6 +420,7 @@ channel_roa_subscribe_filter(struct channel *c, int dir)
   FILTER_ITERATE_END;
 
   FILTER_ITERATE_CLEANUP(&fit);
+  */
 
   if (!valid && found)
     log(L_WARN "%s.%s: Automatic RPKI reload not active for %s",