inotify.lisp

   1 ;;; -*- mode: lisp; syntax: common-lisp; coding: utf-8; package: cl-inotify; -*-
   2
   3 ;; Copyright (c) 2011-12, Olof-Joachim Frahm
   4 ;; All rights reserved.
   5
   6 ;; Redistribution and use in source and binary forms, with or without
   7 ;; modification, are permitted provided that the following conditions
   8 ;; are met:
   9
  10 ;; 1. Redistributions of source code must retain the above copyright
  11 ;; notice, this list of conditions and the following disclaimer.
  12
  13 ;; 2. Redistributions in binary form must reproduce the above copyright
  14 ;; notice, this list of conditions and the following disclaimer in the
  15 ;; documentation and/or other materials provided with the distribution.
  16
  17 ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  18 ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  19 ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  20 ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  21 ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  22 ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
  23 ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  24 ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  25 ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  26 ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  27 ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  28
  29 (in-package #:cl-inotify)
  30
  31 (defbitfield (inotify1-flag :int)
  32   (:cloexec       #.in-cloexec)
  33   (:nonblock      #.in-nonblock))
  34
  35 (defbitfield (inotify-flag :uint32)
  36   (:access        #.in-access)
  37   (:modify        #.in-modify)
  38   (:attrib        #.in-attrib)
  39   (:close-write   #.in-close-write)
  40   (:close-nowrite #.in-close-nowrite)
  41   (:close         #.in-close)
  42   (:open          #.in-open)
  43   (:moved-from    #.in-moved-from)
  44   (:moved-to      #.in-moved-to)
  45   (:move          #.in-move)
  46   (:create        #.in-create)
  47   (:delete        #.in-delete)
  48   (:delete-self   #.in-delete-self)
  49   (:move-self     #.in-move-self)
  50   (:unmount       #.in-unmount)
  51   (:q-overflow    #.in-q-overflow)
  52   (:ignored       #.in-ignored)
  53   (:onlydir       #.in-onlydir)
  54   (:dont-follow   #.in-dont-follow)
  55   (:mask-add      #.in-mask-add)
  56   (:isdir         #.in-isdir)
  57   (:oneshot       #.in-oneshot)
  58   (:all-events    #.in-all-events))
  59
  60 (deftype inotify-add/read-flag ()
  61   "Shared valid flags for the WATCH-RAW and READ-EVENT functions."
  62   '(member
  63     :access :attrib
  64     :close-write :close-nowrite :close
  65     :create :delete :delete-self
  66     :modify
  67     :move-self :moved-from :moved-to :move
  68     :open :all-events))
  69
  70 (deftype inotify-read-flag ()
  71   "Valid flags which are returned from READ-EVENT."
  72   '(or inotify-add/read-flag
  73     (member :ignored :isdir :q-overflow :unmount)))
  74
  75 (deftype inotify-add-flag ()
  76   "Valid flags for the WATCH-RAW function."
  77   '(or inotify-add/read-flag
  78     (member :dont-follow :mask-add :oneshot :onlydir)))
  79
  80 (defun valid-watch-flag-p (x)
  81   (and (typep x 'inotify-add-flag)
  82        (not (eq :mask-add x))
  83        (not (eq :oneshot x))))
  84
  85 (defun valid-watch-flag-list-p (list)
  86   (every #'valid-watch-flag-p list))
  87
  88 (deftype watch-flag-list ()
  89   "Valid flags argument for the WATCH function, a list of keywords from
  90 INOTIFY-ADD-FLAG.  Basically only :MASK-ADD and :ONESHOT are removed.
  91 The :MASK-ADD behaviour is replicated with the REPLACE-P argument; the
  92 :ONESHOT behaviour doesn't play well with the WATCH function design (and
  93 thus should be used only with WATCH-RAW)."
  94   '(or (satisfies valid-watch-flag-p)
  95        (and list (satisfies valid-watch-flag-list-p))))
  96
  97 (defsyscall inotify-init :int
  98   "Initialises a new inotify event queue.")
  99
 100 (defsyscall inotify-init1 :int
 101   "Initialises a new inotify event queue and passes some flags along."
 102   (flags inotify1-flag))
 103
 104 (defsyscall inotify-add-watch :int
 105   "Watches a path on a event queue."
 106   (fd :int)
 107   (pathname :string)
 108   (mask inotify-flag))
 109
 110 (defsyscall inotify-rm-watch :int
 111   "Removes a watched path from a event queue."
 112   (fd :int)
 113   (wd :int))
 114
 115 (binary-types:define-signed int #.(cffi:foreign-type-size :int))
 116
 117 (binary-types:define-binary-struct inotify-event ()
 118   "An inotify native event structure.
 119 WD is the watch/file descriptor,
 120 MASK is the (parsed) combination of events,
 121 COOKIE is a unique integer which connects related events,
 122 NAME optionally identifies a file relative to a watched directory."
 123   (wd 0 :binary-type int)
 124   (mask 0 :binary-type binary-types:u32)
 125   (cookie 0 :binary-type binary-types:u32)
 126   (name NIL))
 127
 128 (defstruct (inotify-instance
 129              (:constructor make-inotify-instance ())
 130              (:conc-name inotify-))
 131   "Contains the stream and file descriptor for a inotify instance."
 132   fd
 133   stream
 134   nonblocking)
 135
 136 ;;;; initialisation and stuff
 137
 138 (eval-when (:compile-toplevel :load-toplevel :execute)
 139   (defun read-new-value (&optional (stream *query-io*))
 140     "READs a value from the STREAM and returns it (wrapped in a list)."
 141     (format stream "~&Enter a new value (unevaluated): ")
 142     (force-output stream)
 143     (list (read stream))))
 144
 145 (eval-when (:compile-toplevel :load-toplevel :execute)
 146   (defun init-endian ()
 147     "Initialises the endianess for the BINARY-TYPES library.  Is automatically
 148 called when the library is loaded."
 149     (setf binary-types:*endian*
 150           (restart-case #+little-endian :little-endian
 151                         #+big-endian :big-endian
 152                         #-(or little-endian big-endian) (error "unknown endianess")
 153                         (use-value (value)
 154                           :report "Enter a correct value (either :LITTLE-ENDIAN or :BIG-ENDIAN)."
 155                           :interactive read-new-value
 156                           ;; TODO: better way to test for correct value/retry values?
 157                           (case value
 158                             ((:little-endian :big-endian) value)
 159                             (T (error "wrong value supplied (not :LITTLE-ENDIAN or :BIG-ENDIAN)"))))))))
 160
 161 ;; initialise the endianess
 162 (eval-when (:compile-toplevel :load-toplevel :execute)
 163   (init-endian))
 164
 165 ;;;; basic wrapping of the API
 166
 167 (defun read-raw-event-from-stream (stream)
 168   "Reads a raw event from the inotify stream."
 169   (let* ((event (binary-types:read-binary 'inotify-event stream))
 170          (len (binary-types:read-binary 'binary-types:u32 stream)))
 171     (when (plusp len)
 172       (with-slots (name) event
 173         (let ((buffer (make-array len :element-type '(unsigned-byte 8))))
 174           (read-sequence buffer stream :end len)
 175           (setf name (trivial-utf-8:utf-8-bytes-to-string buffer :end (position 0 buffer))))))
 176     event))
 177
 178 (defun read-event-from-stream (stream)
 179   "Reads a event from the inotify stream and converts bitmasks on reading."
 180   (let ((event (read-raw-event-from-stream stream)))
 181     (with-slots (mask) event
 182       (setf mask (foreign-bitfield-symbols 'inotify-flag mask)))
 183     event))
 184
 185 (defun set-nonblocking (fd nonblocking)
 186   "Enables or disables NONBLOCKING mode on a file descriptor FD."
 187   (let ((flags (osicat-posix:fcntl fd osicat-posix:f-getfl)))
 188     ;; an error is raised if this fails, so we don't have to do it ourselves
 189     (osicat-posix:fcntl fd osicat-posix:f-setfl
 190                         (funcall (if nonblocking #'logior #'logxor)
 191                                  flags osicat-posix:o-nonblock)))
 192   (values))
 193
 194 (defun init-unregistered-inotify (inotify &optional (nonblocking T))
 195   "Creates a new inotify event queue.  If NONBLOCKING is set (default),
 196 the file descriptor is set to non-blocking I/O."
 197   (with-slots (fd stream (non-block nonblocking)) inotify
 198     (unwind-protect
 199          ;; file descriptor is collected with auto-close
 200          (progn
 201            (setf fd (inotify-init1 (and (setf non-block nonblocking)
 202                                         :nonblock)))
 203            (setf stream
 204                  ;; TODO: what about the blocking?
 205                  #-(or clisp sbcl)
 206                  (osicat::make-fd-stream
 207                   fd
 208                   :direction :input
 209                   :element-type '(unsigned-byte 8))
 210                  #+clisp
 211                  (ext:make-stream
 212                   fd
 213                   :direction :input
 214                   :element-type '(unsigned-byte 8)
 215                   :buffered (not nonblocking))
 216                  #+sbcl
 217                  (sb-sys:make-fd-stream
 218                   fd
 219                   :input T
 220                   :element-type '(unsigned-byte 8)
 221                   :name (format NIL "inotify event queue ~A" fd)
 222                   :auto-close T
 223                   :buffering (if nonblocking :none :full))))
 224       ;; if stream is constructed, gc'ing it will cleanup the file descriptor
 225       ;; TODO: is this true for clisp?  because the docs say that
 226       ;; EXT:MAKE-STREAM uses dup(2)
 227       (unless stream
 228         (osicat-posix:close fd))))
 229   inotify)
 230
 231 (defun make-unregistered-inotify (&optional (nonblocking T))
 232   "Creates a new unregistered INOTIFY instance."
 233   (init-unregistered-inotify (make-inotify-instance) nonblocking))
 234
 235 (defun close-inotify (inotify)
 236   "Closes the inotify event queue."
 237   (close (inotify-stream inotify))
 238   (values))
 239
 240 (defun ensure-list (arg)
 241   (if (listp arg) arg `(,arg)))
 242
 243 (defun translate-keyword-flags (flags)
 244   (typecase flags
 245     ((or keyword list)
 246      (foreign-bitfield-value 'inotify-flag (ensure-list flags)))
 247     (T flags)))
 248
 249 (defun watch-raw (inotify pathname flags)
 250   "Adds PATHNAME (either of type PATHNAME or STRING) to be watched.  FLAGS
 251 determines how exactly (see inotify(7) for detailed information) and can
 252 be of type LIST, KEYWORD or a raw numerical value (which isn't checked
 253 for validity though).  Returns a handle which can be used with UNWATCH-RAW."
 254   (let* ((path (etypecase pathname
 255                  (string pathname)
 256                  (pathname (namestring pathname)))))
 257     (inotify-add-watch (inotify-fd inotify)
 258                        path (translate-keyword-flags flags))))
 259
 260 (defun unwatch-raw (inotify handle)
 261   "Stops watching the path associated with a HANDLE established by WATCH-RAW."
 262   (inotify-rm-watch (inotify-fd inotify) handle)
 263   (values))
 264
 265 ;;;; support functions, making life easier
 266
 267 (defstruct (registered-inotify-instance
 268              (:include inotify-instance)
 269              (:constructor make-registered-inotify-instance ())
 270              (:conc-name inotify-))
 271   "Additionally to the information in INOTIFY-INSTANCE, records watched
 272 paths in a dictionary."
 273   watched)
 274
 275 (defun make-inotify (&optional (nonblocking T))
 276   "Creates a new registered INOTIFY instance.  In NONBLOCKING mode, the file
 277 descriptor is set to non-blocking mode.  The resulting object has to be
 278 closed with CLOSE-INOTIFY."
 279   (let ((result (make-registered-inotify-instance)))
 280     (init-unregistered-inotify result nonblocking)
 281     (with-slots (watched) result
 282       (setf watched (make-hash-table :test 'equal)))
 283     result))
 284
 285 (defun pathname-handle/flags (inotify pathname)
 286   "Returns a CONS cell with the values HANDLE and FLAGS if PATHNAME is
 287 being watched by INOTIFY, else NIL.  The match is exact."
 288   (gethash pathname (inotify-watched inotify)))
 289
 290 (defun event-pathname/flags (inotify event &optional (handle (slot-value event 'wd)))
 291   "Returns two values PATHNAME and FLAGS for an EVENT which were used during
 292 registration.  If HANDLE is specified EVENT is ignored."
 293   (block NIL
 294     (maphash (lambda (pathname entry)
 295                (when (eql (car entry) handle)
 296                  (return (values pathname (cdr entry)))))
 297              (inotify-watched inotify))))
 298
 299 (defun sane-user-flags (inotify pathname flags &key (replace-p T))
 300   (check-type flags watch-flag-list)
 301   ;; now, :mask-add can't be member of flags
 302   ;; merge the flags
 303   (let* ((flags (ensure-list flags))
 304          (rep-flags (if replace-p
 305                         (cons :mask-add flags)
 306                         flags)))
 307     (let ((it (gethash pathname (slot-value inotify 'watched))))
 308       (if it
 309           (union (cdr it) rep-flags :test #'eq)
 310           rep-flags))))
 311
 312 (defun watch (inotify pathname flags &key (replace-p T))
 313   "Adds PATHNAME (either pathname or string) to be watched and records the
 314 watched paths.  FLAGS (a list of keywords) determines how exactly (see
 315 inotify(7) for detailed information).  Returns a handle which can be used
 316 with UNWATCH and EVENT-PATHNAME/FLAGS.  If REPLACE-P is set to T (default),
 317 the flags mask is replaced rather than OR-ed to the current mask (if it
 318 exists).  The :MASK-ADD flag is therefore removed from the FLAGS argument."
 319   (let* ((flags (sane-user-flags inotify pathname flags :replace-p replace-p))
 320          (handle (watch-raw inotify pathname flags)))
 321     (with-slots (watched) inotify
 322       (setf (gethash pathname watched) (cons handle flags)))
 323     handle))
 324
 325 (defun unwatch (inotify &key pathname event handle)
 326   "Disables watching the path associated with the supplied HANDLE (which
 327 may be one from a given EVENT) or PATHNAME."
 328   (unless (or pathname event handle)
 329     (error "either PATHNAME, EVENT or HANDLE have to be specified"))
 330   (when event
 331     (setf handle (slot-value event 'wd)))
 332   (if handle
 333       (unwatch-raw inotify handle)
 334       (let ((handle (car (pathname-handle/flags inotify pathname))))
 335         (unless handle
 336           (error "PATHNAME ~S isn't being watched" pathname))
 337         ;; remove even if unwatch-raw throws an error (which can happen if :oneshot is specified)
 338         (remhash pathname (inotify-watched inotify))
 339         (unwatch-raw inotify handle)))
 340   (values))
 341
 342 (defun list-watched (inotify)
 343   "Returns a LIST of all watched pathnames in no particular order."
 344   (loop
 345     for pathname being each hash-key in (inotify-watched inotify)
 346     collect pathname))
 347
 348 (defun unix-eagain-p (fd)
 349   "Returns T on a file descriptor if trying to read raised an EAGAIN
 350 error."
 351   (handler-case (prog1 NIL (osicat-posix:read fd (null-pointer) 0))
 352     ;; we have to check for both to be portable, says read(2)
 353     (osicat-posix:eagain () T)
 354     (osicat-posix:ewouldblock () T)
 355     ;; this is set if the kernel is newer than 2.6.21 if the buffer is
 356     ;; too small to get the next event (which it certainly is)
 357     (osicat-posix:einval () NIL)))
 358
 359 (defun event-available-p (inotify)
 360   "Returns T if an event is available on the queue."
 361   (if (inotify-nonblocking inotify)
 362       (not (unix-eagain-p (inotify-fd inotify)))
 363       (listen (inotify-stream inotify))))
 364
 365 (defun read-event (inotify)
 366   "Reads an event from the queue.  Blocks if no event is available."
 367   (read-event-from-stream (inotify-stream inotify)))
 368
 369 (defun next-event (inotify)
 370   "Reads an event from the queue.  Returns NIL if none is available."
 371   (when (event-available-p inotify)
 372     (read-event inotify)))
 373
 374 (defmacro do-events ((var inotify &key blocking-p) &body body)
 375   "Loops BODY with VAR bound to the next events retrieved from INOTIFY.
 376 The macro uses NEXT-EVENT, so reading an event won't block and the loop
 377 terminates if no events are available.  If BLOCKING-P is set, the loop
 378 blocks if no events are available, otherwise it exits as soon as no
 379 events were encountered."
 380   (check-type var symbol)
 381   (let ((inotify-sym (gensym)))
 382    `(loop
 383       with ,var and ,inotify-sym = ,inotify
 384       ,.(unless blocking-p
 385           `(while (event-available-p ,inotify-sym)))
 386       do (progn
 387            (setf ,var (read-event ,inotify-sym))
 388            ,@body))))
 389
 390 (defun next-events (inotify)
 391   "Reads all available events from the queue.  Returns a LIST of events."
 392   (loop
 393     while (event-available-p inotify)
 394     collect (read-event inotify)))
 395
 396 ;;; this has the longer name, because this way you actually have to read
 397 ;;; about the differences, at least i hope so
 398 (defmacro with-unregistered-inotify ((inotify &optional (nonblocking T) &rest rest) &body body)
 399   "Like WITH-INOTIFY, but uses MAKE-UNREGISTERED-INOTIFY and WATCH-RAW
 400 instead.  Useful if you need to monitor just a fixed set of paths."
 401   `(let ((,inotify (make-unregistered-inotify ,nonblocking)))
 402      (unwind-protect
 403           (progn
 404             ,.(mapcar (lambda (specifier)
 405                         `(watch-raw ,inotify ,@specifier))
 406                       rest)
 407             ,@body)
 408        (close-inotify ,inotify))))
 409
 410 (defmacro with-inotify ((inotify &optional (nonblocking T) &rest rest) &body body)
 411   "Executes BODY with a newly created queue bound to INOTIFY if true.
 412 See MAKE-INOTIFY for more information about possible arguments.
 413
 414 The REST is a list of argument forms for the WATCH function, i.e. one or
 415 more forms (PATHNAME FLAGS &KEY (REPLACE-P T)).
 416
 417 Since the QUEUE is closed on unwinding, this macro doesn't bother with
 418 UNWATCH calls on all WATCHed paths."
 419   `(let ((,inotify (make-inotify ,nonblocking)))
 420      (unwind-protect
 421           (progn
 422             ,.(mapcar (lambda (specifier)
 423                         `(watch ,inotify ,@specifier))
 424                       rest)
 425             ,@body)
 426        (close-inotify ,inotify))))