update minisock to not scribble on lua strings

and add ids to subscribe so that there's a unique identifier
to pass to unsubscribe

pkgs/default.nix

@@ -56,6 +56,7 @@ in {
   # please keep the rest of this list alphabetised :-)
 
   anoia = callPackage ./anoia {};
+  devout = callPackage ./devout {};
   fennel = callPackage ./fennel {};
   fennelrepl = callPackage ./fennelrepl {};
   firewallgen = callPackage ./firewallgen {};

pkgs/devout/default.nix

@@ -0,0 +1,27 @@
+{
+  lua
+, nellie
+, writeFennel
+, anoia
+, fennel
+, stdenv
+, fennelrepl
+, minisock
+}:
+stdenv.mkDerivation {
+  name = "devout";
+  src = ./.;
+  checkInputs = [ fennelrepl ];
+  installPhase = ''
+    mkdir -p $out/bin
+    cp -p ${writeFennel "devout" {
+      packages = [fennel anoia nellie lua.pkgs.luafilesystem minisock];
+      mainFunction = "run";
+    } ./devout.fnl} $out/bin/devout
+  '';
+  checkPhase = ''
+    LUA_CPATH=${minisock}/lib/lua/5.3/?.so\;$LUA_CPATH \
+    fennelrepl ./test.fnl
+  '';
+  doCheck = true;
+}

pkgs/devout/devout.fnl

@@ -0,0 +1,127 @@
+(local sock (require :minisock))
+(local { : view } (require :fennel))
+
+(fn trace [expr]
+  (doto expr (print :TRACE (view expr))))
+
+(fn parse-uevent [s]
+  (let [at (string.find s "@" 1 true)
+        (nl nxt) (string.find s "\0" 1 true)]
+    (doto
+        (collect [k v (string.gmatch
+                       (string.sub s (+ 1 nxt))
+                       "(%g-)=(%g+)")]
+          (k:lower) v)
+      (tset :path (string.sub s (+ at 1) (- nl 1))))))
+
+(fn event-matches? [e terms]
+  (accumulate [match? true
+               name value (pairs terms)]
+    (and match? (= value (. e name)))))
+
+(fn find-in-database [db terms]
+  (accumulate [found []
+               _ e (pairs db)]
+    (if (event-matches? e terms)
+        (doto found (table.insert e))
+        found)))
+
+(fn record-event [db subscribers str]
+  (let [e (parse-uevent str)]
+    (match e.action
+      :add (tset db e.path e)
+      :change (tset db e.path e)
+      ;; should we do something for bind?
+      :remove (tset db e.path nil)
+      )
+    (each [_ { : terms : callback } (pairs subscribers)]
+      (if (event-matches? e terms) (callback e)))
+    e))
+
+(fn database []
+  (let [db {}
+        subscribers []]
+    {
+     :find (fn [_ terms] (find-in-database db terms))
+     :add (fn [_ event-string] (record-event db subscribers event-string))
+     :at-path (fn [_ path] (. db path))
+     :subscribe (fn [_ id callback terms]
+                  (tset subscribers id {: callback : terms }))
+     :unsubscribe (fn [_ id] (tset subscribers id nil))
+     }))
+
+;; #define POLLIN          0x0001
+;; #define POLLPRI         0x0002
+;; #define POLLOUT         0x0004
+;; #define POLLERR         0x0008
+;; #define POLLHUP         0x0010
+;; #define POLLNVAL        0x0020
+
+(fn unix-socket [name]
+  (let [addr (.. "\1\0"  name  "\0\0\0\0\0")
+        (sock err) (sock.bind addr)]
+    (assert sock err)))
+
+(fn pollfds-for [fds]
+  (table.concat (icollect [_ v (ipairs fds)] (string.pack "iHH" v 1 0))))
+
+(fn unpack-pollfds [pollfds]
+  (var i 1)
+  (let [fds {}]
+    (while (< i (# pollfds))
+      (let [(fd _ revents i_) (string.unpack "iHH" pollfds i)]
+        (if (> revents 0) (tset fds fd revents))
+        (set i i_)))
+    fds))
+
+(fn parse-terms [str]
+  (print :terms str)
+  (collect [n (string.gmatch str "([^ ]+)")]
+    (string.match n "(.-)=(.+)")))
+
+(fn handle-client [db client]
+  (match (trace (sock.read client))
+    "" (do
+         (db:unsubscribe client)
+         false)
+    s (do
+        (db:subscribe
+         client
+         (fn [e]
+           (sock.write client (view e)))
+         (parse-terms s))
+        true)
+    (nil err) (do (print err) false)))
+
+(fn event-loop []
+  (let [fds {}]
+    {
+     :register #(tset fds $2 $3)
+     :feed (fn [_ revents]
+             (each [fd revent (pairs revents)]
+               (when (not ((. fds fd) fd))
+                 (tset fds fd nil)
+                 (sock.close fd))))
+     :fds #(icollect [fd _ (pairs fds)] fd)
+    :_tbl #(do fds)                    ;exposed for tests
+     }))
+
+(fn run []
+  (let [[sockname] arg
+        s (unix-socket sockname)
+        db (database)
+        loop (event-loop)]
+    (loop:register
+     s
+     #(match (sock.accept s)
+        (client addr)
+        (do
+          (loop:register client (partial handle-client db))
+          true)))
+    (while true
+      (let [pollfds (pollfds-for (loop:fds))
+            (rpollfds numfds) (sock.poll pollfds 1000)]
+        (when (> numfds 0)
+          (loop:feed (unpack-pollfds rpollfds)))))))
+
+{ : database : run : event-loop  }

pkgs/devout/test.fnl

@@ -0,0 +1,185 @@
+(local { : database : event-loop } (require :devout))
+(local { : view } (require :fennel))
+(local sock (require :minisock))
+(import-macros { : expect : expect= } :anoia.assert)
+
+(var failed false)
+(fn fail [d msg] (set failed true) (print :FAIL d (.. "\n" msg)))
+
+(macro example [description & body]
+  (if (. body 1)
+      `(let [(ok?# err#) (xpcall (fn [] ,body) debug.traceback)]
+         (if ok?#
+             (print :PASS ,description)
+             (fail ,description err#)))
+      `(print :PENDING ,description)))
+
+(example
+ "given an empty database, searching it finds no entries"
+ (let [db (database)]
+   (expect= (db:find {:partname "boot"}) [])))
+
+(local sda-uevent
+       "add@/devices/pci0000:00/0000:00:13.0/usb1/1-1/1-1:1.0/host0/target0:0:0/0:0:0:0/block/sda\0ACTION=add
+DEVPATH=/devices/pci0000:00/0000:00:13.0/usb1/1-1/1-1:1.0/host0/target0:0:0/0:0:0:0/block/sda
+SUBSYSTEM=block
+MAJOR=8
+MINOR=0
+DEVNAME=sda
+DEVTYPE=disk
+DISKSEQ=2
+SEQNUM=1527")
+
+(local sdb1-insert
+       "add@/devices/pci0000:00/0000:00:14.0/usb1/1-3/1-3:1.0/host1/target1:0:0/1:0:0:0/block/sdb/sdb1\0ACTION=add
+DEVPATH=/devices/pci0000:00/0000:00:14.0/usb1/1-3/1-3:1.0/host1/target1:0:0/1:0:0:0/block/sdb/sdb1
+SUBSYSTEM=block
+DEVNAME=/dev/sdb1
+DEVTYPE=partition
+DISKSEQ=33
+PARTN=1
+SEQNUM=82381
+MAJOR=8
+MINOR=17")
+
+(local sdb1-remove
+       "remove@/devices/pci0000:00/0000:00:14.0/usb1/1-3/1-3:1.0/host1/target1:0:0/1:0:0:0/block/sdb/sdb1\0ACTION=remove
+DEVPATH=/devices/pci0000:00/0000:00:14.0/usb1/1-3/1-3:1.0/host1/target1:0:0/1:0:0:0/block/sdb/sdb1
+SUBSYSTEM=block
+DEVNAME=/dev/sdb1
+DEVTYPE=partition
+DISKSEQ=33
+PARTN=1
+SEQNUM=82386
+MAJOR=8
+MINOR=17")
+
+
+(example
+ "when I add a device, I can find it"
+ (let [db (database)]
+   (db:add sda-uevent)
+   (let [[m & more] (db:find {:devname "sda"})]
+     (expect= m.devname "sda")
+     (expect= m.major "8")
+     (expect= more []))))
+
+(example
+ "when I add a device, I cannot find it with wrong terms"
+ (let [db (database)]
+   (db:add sda-uevent)
+   (expect= (db:find {:devname "sdb"}) [])))
+
+(example
+ "when I add a device, I can retrieve it by path"
+ (let [db (database)]
+   (db:add sda-uevent)
+   (let [m (db:at-path "/devices/pci0000:00/0000:00:13.0/usb1/1-1/1-1:1.0/host0/target0:0:0/0:0:0:0/block/sda")]
+     (expect= m.devname "sda")
+     (expect= m.major "8"))))
+
+(example
+ "when I add and then remove a device, I cannot retrieve it by path"
+ (let [db (database)]
+   (db:add sdb1-insert)
+   (db:add sdb1-remove)
+   (expect= (db:at-path "/devices/pci0000:00/0000:00:14.0/usb1/1-3/1-3:1.0/host1/target1:0:0/1:0:0:0/block/sdb/sdb1") nil)))
+
+(example
+ "when I add and then remove a device, I cannot find it"
+ (let [db (database)]
+   (db:add sdb1-insert)
+   (db:add sda-uevent)
+   (db:add sdb1-remove)
+   (expect= (db:find {:devname "/dev/sdb1"}) [])))
+
+(example
+ "when I search on multiple terms it uses all of them"
+ (let [db (database)]
+   (db:add sda-uevent)
+   (expect= (# (db:find {:devname "sda" :devtype "disk"})) 1)
+   (expect= (# (db:find {:devname "sda" :devtype "dosk"})) 0)))
+
+
+;;; tests for indices
+
+(example "when I add a device with $attributes major minor foo bar baz,
+ it is added to indices for foo bar baz but not major minor")
+
+(example "a removed device can no longer be found by looking in any index")
+
+(example "when I query with multiple attributes, the search is performed using the most specific attribute"
+         ;; (= the attribute whose
+         ;;   value at this key has fewest elements)
+         )
+
+;;; tests for subscriptions
+
+(example
+ "I can subscribe to some search terms and be notified of matching events"
+ (var received [])
+ (let [db (database)
+       subscriber (fn [e] (table.insert received e))]
+   (db:subscribe :me subscriber {:devname "/dev/sdb1"})
+   (db:add sdb1-insert)
+   (db:add sda-uevent)
+   (db:add sdb1-remove)
+   (expect= (# received) 2)))
+
+(example
+ "I can unsubscribe after subscribing"
+ (var received [])
+ (let [db (database)
+       subscriber (fn [e] (table.insert received e))]
+   (db:subscribe :me subscriber {:devname "/dev/sdb1"})
+   (db:unsubscribe :me)
+   (db:add sdb1-insert)
+   (db:add sda-uevent)
+   (db:add sdb1-remove)
+   (expect= (# received) 0)))
+
+
+;;; test for event loop
+
+(example
+ "I can register a fd with a callback"
+ (let [loop (event-loop)
+       cb #(print $1)]
+   (loop:register 3 cb)
+   (expect= (. (loop:_tbl) 3) cb)))
+
+(example
+ "when the fd is ready, my callback is called"
+ (let [loop (event-loop)]
+   (var ran? false)
+   (loop:register 3 #(set ran? true))
+   (loop:feed {3 1})
+   (expect= ran? true)
+   ))
+
+(example
+ "when the callback returns true it remains registered"
+ (let [loop (event-loop)]
+   (loop:register 3 #true)
+   (loop:feed {3 1})
+   (expect (. (loop:_tbl) 3))
+   ))
+
+(fn new-fd []
+  (let [fd (sock.bind (.. "\1\0"  "/tmp/test-socket"  "\0\0\0\0\0"))]
+    (os.remove "/tmp/test-socket")
+    fd))
+
+(example
+ "when the callback returns false it is unregistered and the fd is closed"
+ (let [loop (event-loop)
+       fd (new-fd)]
+   (expect (> fd 2))
+   (loop:register 3 #false)
+   (loop:feed {3 1})
+   (expect (not (. (loop:_tbl) 3)))
+   (assert (not (os.execute (string.format "test -e /dev/fd/%d" fd))))
+   ))
+
+
+(if failed (os.exit 1) (print "OK"))

pkgs/minisock/default.nix

@@ -1,16 +1,17 @@
 { lua, lib, fetchFromGitHub }:
-let pname = "minisock";
+let
+  pname = "minisock";
+  src = fetchFromGitHub {
+    repo = "minisock";
+    owner = "telent";
+    rev = "46e0470ff88c68f3a873dedbcf1dc351f4916b1a";
+    hash = "sha256-uTV5gpfEMvHMBgdu41Gy2uizc3K9bXtO5BiCY70cYUs=";
+  };
 in lua.pkgs.buildLuaPackage {
   inherit pname;
   version = "0.1";              # :shrug:
 
-  src = fetchFromGitHub {
-    repo = "minisock";
-    owner = "philanc";
-    rev = "a20db2aaa871653c61045019633279167cf1b458";
-    hash = "sha256-zB9KSt0WEGCSYTLA6W9QrsVRFEZYaoBBeXx9VEXmsGY=";
-  };
-
+  inherit src;
   makeFlags = [ "LUADIR=."  "minisock.so" ];
 
   installPhase = ''

pkgs/uevent-watch/default.nix

@@ -1,7 +1,7 @@
 {
   lua
 , nellie
-, writeFennelScript
+, writeFennel
 , runCommand
 , anoia
 , fennel
@@ -14,7 +14,10 @@ stdenv.mkDerivation {
   nativeBuildInputs = [ fennelrepl ];
   installPhase = ''
     mkdir -p $out/bin
-    cp -p ${writeFennelScript "uevent-watch" [fennel anoia nellie lua.pkgs.luafilesystem] ./watch.fnl} $out/bin/uevent-watch
+    cp -p ${writeFennel "uevent-watch" {
+      packages = [fennel anoia nellie lua.pkgs.luafilesystem];
+      mainFunction = "run";
+    } ./watch.fnl} $out/bin/uevent-watch
   '';
   checkPhase = ''
     fennelrepl ./test.fnl

pkgs/uevent-watch/test.fnl

@@ -1,7 +1,6 @@
 (local { : view} (require :fennel))
 (import-macros { : expect= } :anoia.assert)
 
-(set _G.arg (doto [] (tset 0 "test")))
 (local subject (require :watch))
 
 (let [params
@@ -35,7 +34,9 @@
 
 ;; this tests event parsing but not whether anything
 ;; happens as a result of processing them
-(subject.run
- ["-s" "foo" "-n" (os.getenv "TMPDIR") "partname=backup-disk" ]
+(subject.run-with-fh
  { :read (next-event) }
+ ["-s" "foo" "-n" (os.getenv "TMPDIR") "partname=backup-disk" ]
  )
+
+(print "OK")

pkgs/uevent-watch/watch.fnl

@@ -47,7 +47,7 @@
                      "(%g-)=(%g+)")]
         (k:lower) v))))
 
-(fn run [args fh]
+(fn run-with-fh [fh args]
   (set up :unknown)
   (let [parameters
         (assert (parse-args args) (.. "can't parse args: " (table.concat args " ")))]
@@ -62,9 +62,9 @@
         (set finished? (= e nil))
         ))))
 
-(when (not (= (. arg 0) "test"))
+(fn run [args]
   (let [nellie (require :nellie)
         netlink (nellie.open 4)]
-    (run arg netlink)))
+    (run-with-fh netlink arg)))
 
-{ : run  : event-matches? }
+{ : run : run-with-fh : event-matches? }