devout.fnl (6401B)
1 (local { : dirname : merge } (require :anoia)) 2 (local ll (require :lualinux)) 3 (local { 4 : AF_LOCAL 5 : AF_NETLINK 6 : SOCK_STREAM 7 : SOCK_RAW 8 : NETLINK_KOBJECT_UEVENT 9 } (require :anoia.net.constants)) 10 (local { : view } (require :fennel)) 11 12 (fn trace [expr] 13 (do (print :TRACE (view expr)) expr)) 14 15 (macro check-errno [expr] 16 (let [{ :view v } (require :fennel)] 17 `(case ,expr 18 val# val# 19 (nil err#) (error (string.format "%s failed: errno=%d" ,(v expr) err#))))) 20 21 (fn format-event [e] 22 (.. 23 (string.format "%s@%s\0" e.action e.path) 24 (table.concat 25 (icollect [k v (pairs e.properties)] 26 (string.format "%s=%s" (string.upper k) v )) 27 "\n"))) 28 29 (fn attrs-match? [event expected] 30 (accumulate [match? true 31 name value (pairs expected)] 32 (and match? (= value (event:attr name))))) 33 34 (fn ancestor-attrs-match? [event expected] 35 (accumulate [match? true 36 name value (pairs expected)] 37 (and match? (= value (event:ancestor-attr name))))) 38 39 (fn event-matches? [e terms] 40 (accumulate [match? true 41 name value (pairs terms)] 42 (and match? 43 (case name 44 :attr (attrs-match? e value) 45 :attrs (ancestor-attrs-match? e value) 46 other (= value (. e.properties name)))))) 47 48 (fn read-if-exists [pathname] 49 (match (ll.open pathname 0 0) 50 fd (let [s (ll.read fd 4096) 51 s1 (string.gsub s "[ \n]*(.-)[ \n]*" "%1")] 52 (ll.close fd) 53 s1) 54 nil nil)) 55 56 (fn event-ancestor-attr [event name] 57 (fn walk-up [sys-path path name] 58 (when path 59 (or (read-if-exists (.. sys-path "/" path "/" name)) 60 (walk-up sys-path (dirname path) name)))) 61 (walk-up event.sys-path event.path name)) 62 63 (fn event-attr [event name] 64 (read-if-exists (.. event.sys-path "/" event.path "/" name))) 65 66 (fn parse-event [s] 67 (let [at (string.find s "@" 1 true) 68 (nl nxt) (string.find s "\0" 1 true) 69 properties 70 (collect [k v (string.gmatch 71 (string.sub s (+ 1 nxt)) 72 "(%g-)=(%g+)")] 73 (k:lower) v)] 74 { : properties 75 :path (string.sub s (+ at 1) (- nl 1)) 76 :action (string.sub s 1 (- at 1)) 77 :format format-event 78 :matches? event-matches? 79 :attr event-attr 80 :ancestor-attr event-ancestor-attr 81 })) 82 83 (fn find-in-database [db terms] 84 (accumulate [found [] 85 _ e (pairs db)] 86 (if (e:matches? terms) 87 (doto found (table.insert e)) 88 found))) 89 90 (fn record-event [db subscribers e] 91 (match e.action 92 :add (tset db e.path e) 93 :change (tset db e.path e) 94 ;; should we do something for bind? 95 :remove (tset db e.path nil) 96 ) 97 (each [_ { : terms : callback } (pairs subscribers)] 98 (if (e:matches? terms) (callback e))) 99 e) 100 101 (fn database [options] 102 (let [db {} 103 subscribers [] 104 { : sys-path } (or options {:sys-path "/sys" })] 105 { 106 :find (fn [_ terms] (find-in-database db terms)) 107 :add (fn [_ event-string] 108 (when event-string 109 (let [e (doto (parse-event event-string) 110 (tset :sys-path sys-path))] 111 (record-event db subscribers e)))) 112 :at-path (fn [_ path] (. db path)) 113 :subscribe (fn [_ id callback terms] 114 (let [past-events (find-in-database db terms)] 115 (each [_ e (pairs past-events)] 116 (callback e))) 117 (tset subscribers id {: callback : terms })) 118 :unsubscribe (fn [_ id] (tset subscribers id nil)) 119 })) 120 121 ;; grepped from kernel headers 122 123 (local POLLIN 0x0001) 124 (local POLLPRI 0x0002) 125 (local POLLOUT 0x0004) 126 (local POLLERR 0x0008) 127 (local POLLHUP 0x0010) 128 (local POLLNVAL 0x0020) 129 130 131 (fn unix-socket [name] 132 (let [addr (string.pack "=Hz" AF_LOCAL name) 133 fd (check-errno (ll.socket AF_LOCAL SOCK_STREAM 0))] 134 (os.remove name) 135 (check-errno (ll.bind fd addr)) 136 (check-errno (ll.listen fd 32)) 137 fd)) 138 139 (fn pollfds-for [fds] 140 (icollect [_ v (ipairs fds)] 141 (bor (lshift v 32) (lshift 1 16)))) 142 143 (fn unpack-pollfds [pollfds] 144 (collect [_ v (ipairs pollfds)] 145 (let [fd (band (rshift v 32) 0xffffffff) 146 revent (band v 0xffff)] 147 (values fd (if (> revent 0) revent nil))))) 148 149 (fn parse-terms [str] 150 (let [keys {} 151 attr {} 152 attrs {}] 153 (each [term (string.gmatch (str:gsub "\n+$" "") "([^ ]+)")] 154 (let [(k v) (string.match term "(.-)=(.+)")] 155 (match (string.match k "(.+)%.(.+)") 156 ("attrs" a) (tset attrs a v) 157 ("attr" a) (tset attr a v) 158 nil (tset keys k v)))) 159 (merge keys {: attr : attrs}))) 160 161 (fn handle-client [db client] 162 (match (ll.read client) 163 "" (do 164 (db:unsubscribe client) 165 false) 166 s (do 167 (db:subscribe 168 client 169 (fn [e] 170 (ll.write client (format-event e))) 171 (parse-terms s)) 172 true) 173 (nil err) (do (print err) false))) 174 175 (fn open-netlink [groups] 176 (let [fd (check-errno (ll.socket AF_NETLINK SOCK_RAW NETLINK_KOBJECT_UEVENT))] 177 (check-errno (ll.bind fd (string.pack "I2I2I4I4" ; family pad pid groups 178 AF_NETLINK 0 0 groups))) 179 fd)) 180 181 (fn event-loop [] 182 (let [fds {}] 183 { 184 :register #(tset fds $2 $3) 185 :feed (fn [_ revents] 186 (each [fd revent (pairs revents)] 187 (when (not ((. fds fd) fd)) 188 (tset fds fd nil) 189 (ll.close fd)))) 190 :fds #(icollect [fd _ (pairs fds)] fd) 191 :_tbl #(do fds) ;exposed for tests 192 })) 193 194 (fn run [] 195 (let [[sockname nl-groups] arg 196 s (check-errno (unix-socket sockname)) 197 db (database) 198 nl (check-errno (open-netlink nl-groups)) 199 loop (event-loop)] 200 (loop:register 201 s 202 #(case 203 (ll.accept s) 204 (client addr) 205 (do 206 (loop:register client (partial handle-client db)) 207 true) 208 (nil err) 209 (print (string.format "error accepting connection, errno=%d" err)))) 210 (loop:register 211 nl 212 #(do (db:add (ll.read nl)) true)) 213 (ll.write 10 "ready\n") 214 (while true 215 (let [pollfds (pollfds-for (loop:fds))] 216 (ll.poll pollfds 5000) 217 (loop:feed (unpack-pollfds pollfds)))))) 218 219 { : database : run : event-loop : parse-event 220 221 : parse-terms 222 }