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 (inotify-flag :uint32)
  32   (:access        #.in-access)
  33   (:modify        #.in-modify)
  34   (:attrib        #.in-attrib)
  35   (:close-write   #.in-close-write)
  36   (:close-nowrite #.in-close-nowrite)
  37   (:close         #.in-close)
  38   (:open          #.in-open)
  39   (:moved-from    #.in-moved-from)
  40   (:moved-to      #.in-moved-to)
  41   (:move          #.in-move)
  42   (:create        #.in-create)
  43   (:delete        #.in-delete)
  44   (:delete-self   #.in-delete-self)
  45   (:move-self     #.in-move-self)
  46   (:unmount       #.in-unmount)
  47   (:q-overflow    #.in-q-overflow)
  48   (:ignored       #.in-ignored)
  49   (:onlydir       #.in-onlydir)
  50   (:dont-follow   #.in-dont-follow)
  51   (:mask-add      #.in-mask-add)
  52   (:isdir         #.in-isdir)
  53   (:oneshot       #.in-oneshot)
  54   (:all-events    #.in-all-events))
  55
  56 (deftype inotify-add/read-flag ()
  57   "Shared valid flags for the WATCH-RAW and READ-EVENT functions."
  58   '(member
  59     :access :attrib
  60     :close-write :close-nowrite :close
  61     :create :delete :delete-self
  62     :modify
  63     :move-self :moved-from :moved-to :move
  64     :open :all-events))
  65
  66 (deftype inotify-read-flag ()
  67   "Valid flags which are returned from READ-EVENT."
  68   '(or inotify-add/read-flag
  69     (member :ignored :isdir :q-overflow :unmount)))
  70
  71 (deftype inotify-add-flag ()
  72   "Valid flags for the WATCH-RAW function."
  73   '(or inotify-add/read-flag
  74     (member :dont-follow :mask-add :oneshot :onlydir)))
  75
  76 (defun valid-watch-flag-p (x)
  77   (and (typep x 'inotify-add-flag)
  78        (not (eq :mask-add x))
  79        (not (eq :oneshot x))))
  80
  81 (defun valid-watch-flag-list-p (list)
  82   (every #'valid-watch-flag-p list))
  83
  84 (deftype watch-flag-list ()
  85   "Valid flags argument for the WATCH function, a list of keywords from
  86 INOTIFY-ADD-FLAG.  Basically only :MASK-ADD and :ONESHOT are removed.
  87 The :MASK-ADD behaviour is replicated with the REPLACE-P argument; the
  88 :ONESHOT behaviour doesn't play well with the WATCH function design (and
  89 thus should be used only with WATCH-RAW)."
  90   '(or (satisfies valid-watch-flag-p)
  91        (and list (satisfies valid-watch-flag-list-p))))
  92
  93 (defcfun ("inotify_init" c-inotify-init) :int
  94   "Initialises a new inotify event queue.")
  95
  96 (defcfun ("inotify_add_watch" c-inotify-add-watch) :int
  97   "Watches a path on a event queue."
  98   (fd :int)
  99   (pathname :string)
 100   (mask inotify-flag))
 101
 102 (defcfun ("inotify_rm_watch" c-inotify-rm-watch) :int
 103   "Removes a watched path from a event queue."
 104   (fd :int)
 105   (wd :int))
 106
 107 (binary-types:define-signed int #.(cffi:foreign-type-size :int))
 108
 109 (binary-types:define-binary-struct inotify-event ()
 110   "An inotify native event structure.
 111 WD is the watch/file descriptor,
 112 MASK is the (parsed) combination of events,
 113 COOKIE is a unique integer which connects related events,
 114 NAME optionally identifies a file relative to a watched directory."
 115   (wd 0 :binary-type int)
 116   (mask 0 :binary-type binary-types:u32)
 117   (cookie 0 :binary-type binary-types:u32)
 118   (name NIL))
 119
 120 (defstruct (inotify-instance
 121              (:constructor make-inotify-instance ())
 122              (:conc-name inotify-))
 123   "Contains the stream and file descriptor for a inotify instance."
 124   fd
 125   stream
 126   nonblocking)
 127
 128 ;;;; initialisation and stuff
 129
 130 (eval-when (:compile-toplevel :load-toplevel :execute)
 131   (defun read-new-value (&optional (stream *query-io*))
 132     "READs a value from the STREAM and returns it (wrapped in a list)."
 133     (format stream "~&Enter a new value (unevaluated): ")
 134     (force-output stream)
 135     (list (read stream))))
 136
 137 (eval-when (:compile-toplevel :load-toplevel :execute)
 138   (defun init-endian ()
 139     "Initialises the endianess for the BINARY-TYPES library.  Is automatically
 140 called when the library is loaded."
 141     (setf binary-types:*endian*
 142           (restart-case #+little-endian :little-endian
 143                         #+big-endian :big-endian
 144                         #-(or little-endian big-endian) (error "unknown endianess")
 145                         (use-value (value)
 146                           :report "Enter a correct value (either :LITTLE-ENDIAN or :BIG-ENDIAN)."
 147                           :interactive read-new-value
 148                           ;; TODO: better way to test for correct value/retry values?
 149                           (case value
 150                             ((:little-endian :big-endian) value)
 151                             (T (error "wrong value supplied (not :LITTLE-ENDIAN or :BIG-ENDIAN)"))))))))
 152
 153 ;; initialise the endianess
 154 (eval-when (:compile-toplevel :load-toplevel :execute)
 155   (init-endian))
 156
 157 ;;;; basic wrapping of the API
 158
 159 (defun read-raw-event-from-stream (stream)
 160   "Reads a raw event from the inotify stream."
 161   (let* ((event (binary-types:read-binary 'inotify-event stream))
 162          (len (binary-types:read-binary 'binary-types:u32 stream)))
 163     (when (plusp len)
 164       (with-slots (name) event
 165         (let ((buffer (make-array len :element-type '(unsigned-byte 8))))
 166           (read-sequence buffer stream :end len)
 167           (setf name (trivial-utf-8:utf-8-bytes-to-string buffer :end (position 0 buffer))))))
 168     event))
 169
 170 (defun read-event-from-stream (stream)
 171   "Reads a event from the inotify stream and converts bitmasks on reading."
 172   (let ((event (read-raw-event-from-stream stream)))
 173     (with-slots (mask) event
 174       (setf mask (foreign-bitfield-symbols 'inotify-flag mask)))
 175     event))
 176
 177 (defun set-nonblocking (fd nonblocking)
 178   "Enables or disables NONBLOCKING mode on a file descriptor FD."
 179   (let ((flags (sb-posix:fcntl fd sb-posix:f-getfl)))
 180     ;; an error is raised if this fails, so we don't have to do it ourselves
 181     (sb-posix:fcntl fd sb-posix:f-setfl
 182                     (funcall (if nonblocking #'logior #'logxor)
 183                              flags sb-posix:o-nonblock)))
 184   (values))
 185
 186 (defun init-unregistered-inotify (inotify &optional (nonblocking T))
 187   "Creates a new inotify event queue.  If NONBLOCKING is set (default),
 188 the file descriptor is set to non-blocking I/O."
 189   (let ((result (c-inotify-init)))
 190     (when (minusp result)
 191       (perror "inotify_init failed"))
 192     (with-slots (fd stream (non-block nonblocking)) inotify
 193       (unwind-protect
 194            ;; file descriptor is collected with auto-close
 195            (progn
 196              (setf fd result)
 197              (when nonblocking
 198                (set-nonblocking fd T)
 199                (setf non-block nonblocking))
 200              (setf stream
 201                    (sb-sys:make-fd-stream
 202                     fd
 203                     :input T
 204                     :element-type '(unsigned-byte 8)
 205                     :name (format NIL "inotify event queue ~A" fd)
 206                     :auto-close T
 207                     :buffering (if nonblocking :none :full))))
 208         ;; if stream is constructed, gc'ing it will cleanup the file descriptor
 209         (unless stream
 210           (sb-posix:close fd)))))
 211   inotify)
 212
 213 (defun make-unregistered-inotify (&optional (nonblocking T))
 214   "Creates a new unregistered INOTIFY instance."
 215   (init-unregistered-inotify (make-inotify-instance) nonblocking))
 216
 217 (defun close-inotify (inotify)
 218   "Closes the inotify event queue."
 219   (close (inotify-stream inotify))
 220   (values))
 221
 222 (defun perror (prefix-string)
 223   #+sbcl (sb-int:simple-perror prefix-string)
 224   #-(or sbcl) (error prefix-string))
 225
 226 (defun ensure-list (arg)
 227   (if (listp arg) arg `(,arg)))
 228
 229 (defun translate-keyword-flags (flags)
 230   (typecase flags
 231     ((or keyword list)
 232      (foreign-bitfield-value 'inotify-flag (ensure-list flags)))
 233     (T flags)))
 234
 235 (defun watch-raw (inotify pathname flags)
 236   "Adds PATHNAME (either of type PATHNAME or STRING) to be watched.  FLAGS
 237 determines how exactly (see inotify(7) for detailed information) and can
 238 be of type LIST, KEYWORD or a raw numerical value (which isn't checked
 239 for validity though).  Returns a handle which can be used with UNWATCH-RAW."
 240   (let* ((path (etypecase pathname
 241                  (string pathname)
 242                  (pathname (namestring pathname))))
 243          (result (c-inotify-add-watch (inotify-fd inotify)
 244                                       path (translate-keyword-flags flags))))
 245     (when (minusp result)
 246       (perror "inotify_add_watch failed"))
 247     result))
 248
 249 (defun unwatch-raw (inotify handle)
 250   "Stops watching the path associated with a HANDLE established by WATCH-RAW."
 251   (let ((result (c-inotify-rm-watch (inotify-fd inotify) handle)))
 252     (when (minusp result)
 253       (perror "inotify_rm_watch failed")))
 254   (values))
 255
 256 ;;;; support functions, making life easier
 257
 258 (defstruct (registered-inotify-instance
 259              (:include inotify-instance)
 260              (:constructor make-registered-inotify-instance ())
 261              (:conc-name inotify-))
 262   "Additionally to the information in INOTIFY-INSTANCE, records watched
 263 paths in a dictionary."
 264   watched)
 265
 266 (defun make-inotify (&optional (nonblocking T))
 267   "Creates a new registered INOTIFY instance.  In NONBLOCKING mode, the file
 268 descriptor is set to non-blocking mode.  The resulting object has to be
 269 closed with CLOSE-INOTIFY."
 270   (let ((result (make-registered-inotify-instance)))
 271     (init-unregistered-inotify result nonblocking)
 272     (with-slots (watched) result
 273       (setf watched (make-hash-table :test 'equal)))
 274     result))
 275
 276 (defun pathname-handle/flags (inotify pathname)
 277   "Returns a CONS cell with the values HANDLE and FLAGS if PATHNAME is
 278 being watched by INOTIFY, else NIL.  The match is exact."
 279   (gethash pathname (inotify-watched inotify)))
 280
 281 (defun event-pathname/flags (inotify event &optional (handle (slot-value event 'wd)))
 282   "Returns two values PATHNAME and FLAGS for an EVENT which were used during
 283 registration.  If HANDLE is specified EVENT is ignored."
 284   (block NIL
 285     (maphash (lambda (pathname entry)
 286                (when (eql (car entry) handle)
 287                  (return (values pathname (cdr entry)))))
 288              (inotify-watched inotify))))
 289
 290 (defun sane-user-flags (inotify pathname flags &key (replace-p T))
 291   (check-type flags watch-flag-list)
 292   ;; now, :mask-add can't be member of flags
 293   ;; merge the flags
 294   (let* ((flags (ensure-list flags))
 295          (rep-flags (if replace-p
 296                         (cons :mask-add flags)
 297                         flags)))
 298     (let ((it (gethash pathname (slot-value inotify 'watched))))
 299       (if it
 300           (union (cdr it) rep-flags :test #'eq)
 301           rep-flags))))
 302
 303 (defun watch (inotify pathname flags &key (replace-p T))
 304   "Adds PATHNAME (either pathname or string) to be watched and records the
 305 watched paths.  FLAGS (a list of keywords) determines how exactly (see
 306 inotify(7) for detailed information).  Returns a handle which can be used
 307 with UNWATCH and EVENT-PATHNAME/FLAGS.  If REPLACE-P is set to T (default),
 308 the flags mask is replaced rather than OR-ed to the current mask (if it
 309 exists).  The :MASK-ADD flag is therefore removed from the FLAGS argument."
 310   (let* ((flags (sane-user-flags inotify pathname flags :replace-p replace-p))
 311          (handle (watch-raw inotify pathname flags)))
 312     (with-slots (watched) inotify
 313       (setf (gethash pathname watched) (cons handle flags)))
 314     handle))
 315
 316 (defun unwatch (inotify &key pathname event handle)
 317   "Disables watching the path associated with the supplied HANDLE (which
 318 may be one from a given EVENT) or PATHNAME."
 319   (unless (or pathname event handle)
 320     (error "either PATHNAME, EVENT or HANDLE have to be specified"))
 321   (when event
 322     (setf handle (slot-value event 'wd)))
 323   (if handle
 324       (unwatch-raw inotify handle)
 325       (let ((handle (car (pathname-handle/flags inotify pathname))))
 326         (unless handle
 327           (error "PATHNAME ~S isn't being watched" pathname))
 328         ;; remove even if unwatch-raw throws an error (which can happen if :oneshot is specified)
 329         (remhash pathname (inotify-watched inotify))
 330         (unwatch-raw inotify handle)))
 331   (values))
 332
 333 (defun list-watched (inotify)
 334   "Returns a LIST of all watched pathnames in no particular order."
 335   (loop
 336     for pathname being each hash-key in (inotify-watched inotify)
 337     collect pathname))
 338
 339 (defun unix-eagain-p (fd-stream)
 340   "Returns T on a FD-STREAM if trying to read from the stream raised a
 341 EAGAIN error."
 342   (multiple-value-bind (result error)
 343       (sb-unix:unix-read (sb-sys:fd-stream-fd fd-stream) NIL 0)
 344     (declare (ignore result))
 345     (= error sb-unix:eagain)))
 346
 347 (defun event-available-p (inotify)
 348   "Returns T if an event is available on the queue."
 349   (if (inotify-nonblocking inotify)
 350       (not (unix-eagain-p (inotify-stream inotify)))
 351       (listen (inotify-stream inotify))))
 352
 353 (defun read-event (inotify)
 354   "Reads an event from the queue.  Blocks if no event is available."
 355   (read-event-from-stream (inotify-stream inotify)))
 356
 357 (defun next-event (inotify)
 358   "Reads an event from the queue.  Returns NIL if none is available."
 359   (when (event-available-p inotify)
 360     (read-event inotify)))
 361
 362 (defmacro do-events ((var inotify &key blocking-p) &body body)
 363   "Loops BODY with VAR bound to the next events retrieved from INOTIFY.
 364 The macro uses NEXT-EVENT, so reading an event won't block and the loop
 365 terminates if no events are available."
 366   (check-type var symbol)
 367   (let ((inotify-sym (gensym)))
 368    `(loop
 369       with ,var and ,inotify-sym = ,inotify
 370       ,.(unless blocking-p
 371           `(while (event-available-p ,inotify-sym)))
 372       do (progn
 373            (setf ,var (read-event ,inotify-sym))
 374            ,@body))))
 375
 376 (defun next-events (inotify)
 377   "Reads all available events from the queue.  Returns a LIST of events."
 378   (loop
 379     while (event-available-p inotify)
 380     collect (read-event inotify)))
 381
 382 ;;; this has the longer name, because this way you actually have to read
 383 ;;; about the differences, at least i hope so
 384 (defmacro with-unregistered-inotify ((inotify &optional (nonblocking T) &rest rest) &body body)
 385   "Like WITH-INOTIFY, but uses MAKE-UNREGISTERED-INOTIFY and WATCH-RAW
 386 instead.  Useful if you need to monitor just a fixed set of paths."
 387   `(let* ((,inotify (make-unregistered-inotify ,nonblocking)))
 388      (unwind-protect
 389           (progn
 390             ,.(mapcar (lambda (specifier)
 391                         `(watch-raw ,inotify ,@specifier))
 392                       rest)
 393             ,@body)
 394        (close-inotify ,inotify))))
 395
 396 (defmacro with-inotify ((inotify &optional (nonblocking T) &rest rest) &body body)
 397   "Executes BODY with a newly created queue bound to INOTIFY if true.
 398 See MAKE-INOTIFY for more information about possible arguments.
 399
 400 The REST is a list of argument forms for the WATCH function, i.e. one or
 401 more forms (PATHNAME FLAGS &KEY (REPLACE-P T)).
 402
 403 Since the QUEUE is closed on unwinding, this macro doesn't bother with
 404 UNWATCH calls on all WATCHed paths."
 405   `(let* ((,inotify (make-inotify ,nonblocking)))
 406      (unwind-protect
 407           (progn
 408             ,.(mapcar (lambda (specifier)
 409                         `(watch ,inotify ,@specifier))
 410                       rest)
 411             ,@body)
 412        (close-inotify ,inotify))))
 413
 414 ;; TODO: what about other implementations?
 415 #+sbcl
 416 (defmacro with-inotify-event-handler ((inotify
 417                                        &optional (nonblocking T) (registered T)
 418                                        &rest rest)
 419                                       event-handler
 420                                       &body body)
 421   "Registers an INOTIFY queue and runs EVENT-HANDLER with it as only
 422 parameter whenever input happens while the BODY is executed.
 423
 424 Other parameters are passed to WITH-(UNREGISTERED)-INOTIFY depending on the
 425 value of REGISTERED (default T)."
 426   (let ((handle (gensym "HANDLE")))
 427     `(,(if registered 'with-inotify 'with-unregistered-inotify)
 428       (,inotify ,nonblocking ,@rest)
 429       (sb-sys:with-fd-handler
 430           ((inotify-fd ,inotify)
 431            :input
 432            (lambda (,handle)
 433              (declare (ignore ,handle))
 434              (funcall ,event-handler ,inotify)))
 435           ,@body))))
 436
 437 (defun run-inotify-program (program args rest directories flags
 438                             &key function (wait T) event-handler (registered T))
 439   "Runs a program and records all matched events in all DIRECTORIES using
 440 FLAGS.  If EVENT-HANDLER is set, it is instead called with every available
 441 event.
 442
 443 PROGRAM, ARGS and REST are the arguments to SB-EXT:RUN-PROGRAM.  REST is
 444 passed on verbatim except for the WAIT parameter, which is set to false.
 445
 446 PROGRAM may also be a FUNCTION, in which case it is called with
 447 \(ARGS . REST) as arguments and has to return a process object like from
 448 SB-EXT:RUN-PROGRAM.  The process also shouldn't be spawned with WAIT set.
 449
 450 DIRECTORIES is a list of directory arguments for WATCH/-RAW.
 451
 452 WAIT is only valid if FUNCTION is set.  If it is true, after FUNCTION has
 453 returned, we wait until the process has quit.
 454
 455 On supported implementations (SBCL) the FUNCTION parameter may be used to
 456 do some work while the program is running and watched by the inotify queue.
 457 It is called with the process object and the inotify queue as arguments."
 458   (let (events)
 459     (labels ((run ()
 460                (typecase program
 461                  (function (apply program args rest))
 462                  (T
 463                   (apply #'sb-ext:run-program program args :wait NIL rest))))
 464              (events (inotify)
 465                (do-events (event inotify)
 466                  (if event-handler
 467                      (funcall event-handler event)
 468                      (push event events))))
 469              (body (inotify)
 470                (unwind-protect
 471                     (progn
 472                       (let ((register (if registered #'watch #'watch-raw)))
 473                         (mapcar (lambda (directory)
 474                                   (funcall register inotify directory flags))
 475                                 directories))
 476                       (let ((process (run)))
 477                         (if function
 478                             (unwind-protect
 479                                  (funcall function process inotify)
 480                               ;; wait in any case so catching the files will work
 481                               (when wait
 482                                 (sb-ext:process-wait process)))
 483                             (loop
 484                               while (sb-ext:process-alive-p process)
 485                               do (events inotify)
 486                               finally (return (if event-handler
 487                                                   process
 488                                                   (values (nreverse events) process)))))))
 489                  (close-inotify inotify))))
 490       (let ((inotify (if registered (make-inotify) (make-unregistered-inotify))))
 491         (if function
 492             #-sbcl
 493             (error "the FUNCTION parameter is only supported on SBCL for now")
 494             #+sbcl
 495             (sb-sys:with-fd-handler
 496                 ((inotify-fd inotify)
 497                  :input
 498                  (lambda (handle)
 499                    (declare (ignore handle))
 500                    (events inotify)))
 501                 (body inotify))
 502             (body inotify))))))