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."
 378   (check-type var symbol)
 379   (let ((inotify-sym (gensym)))
 380    `(loop
 381       with ,var and ,inotify-sym = ,inotify
 382       ,.(unless blocking-p
 383           `(while (event-available-p ,inotify-sym)))
 384       do (progn
 385            (setf ,var (read-event ,inotify-sym))
 386            ,@body))))
 387
 388 (defun next-events (inotify)
 389   "Reads all available events from the queue.  Returns a LIST of events."
 390   (loop
 391     while (event-available-p inotify)
 392     collect (read-event inotify)))
 393
 394 ;;; this has the longer name, because this way you actually have to read
 395 ;;; about the differences, at least i hope so
 396 (defmacro with-unregistered-inotify ((inotify &optional (nonblocking T) &rest rest) &body body)
 397   "Like WITH-INOTIFY, but uses MAKE-UNREGISTERED-INOTIFY and WATCH-RAW
 398 instead.  Useful if you need to monitor just a fixed set of paths."
 399   `(let* ((,inotify (make-unregistered-inotify ,nonblocking)))
 400      (unwind-protect
 401           (progn
 402             ,.(mapcar (lambda (specifier)
 403                         `(watch-raw ,inotify ,@specifier))
 404                       rest)
 405             ,@body)
 406        (close-inotify ,inotify))))
 407
 408 (defmacro with-inotify ((inotify &optional (nonblocking T) &rest rest) &body body)
 409   "Executes BODY with a newly created queue bound to INOTIFY if true.
 410 See MAKE-INOTIFY for more information about possible arguments.
 411
 412 The REST is a list of argument forms for the WATCH function, i.e. one or
 413 more forms (PATHNAME FLAGS &KEY (REPLACE-P T)).
 414
 415 Since the QUEUE is closed on unwinding, this macro doesn't bother with
 416 UNWATCH calls on all WATCHed paths."
 417   `(let* ((,inotify (make-inotify ,nonblocking)))
 418      (unwind-protect
 419           (progn
 420             ,.(mapcar (lambda (specifier)
 421                         `(watch ,inotify ,@specifier))
 422                       rest)
 423             ,@body)
 424        (close-inotify ,inotify))))
 425
 426 ;; TODO: what about other implementations?
 427 #+sbcl
 428 (defmacro with-inotify-event-handler ((inotify
 429                                        &optional (nonblocking T) (registered T)
 430                                        &rest rest)
 431                                       event-handler
 432                                       &body body)
 433   "Registers an INOTIFY queue and runs EVENT-HANDLER with it as only
 434 parameter whenever input happens while the BODY is executed.
 435
 436 Other parameters are passed to WITH-(UNREGISTERED)-INOTIFY depending on the
 437 value of REGISTERED (default T)."
 438   (let ((handle (gensym "HANDLE")))
 439     `(,(if registered 'with-inotify 'with-unregistered-inotify)
 440       (,inotify ,nonblocking ,@rest)
 441       (sb-sys:with-fd-handler
 442           ((inotify-fd ,inotify)
 443            :input
 444            (lambda (,handle)
 445              (declare (ignore ,handle))
 446              (funcall ,event-handler ,inotify)))
 447           ,@body))))
 448
 449 (defun run-inotify-program (program args rest directories flags
 450                             &key function (wait T) event-handler (registered T))
 451   "Runs a program and records all matched events in all DIRECTORIES using
 452 FLAGS.  If EVENT-HANDLER is set, it is instead called with every available
 453 event.
 454
 455 PROGRAM, ARGS and REST are the arguments to SB-EXT:RUN-PROGRAM.  REST is
 456 passed on verbatim except for the WAIT parameter, which is set to false.
 457
 458 PROGRAM may also be a FUNCTION, in which case it is called with
 459 \(ARGS . REST) as arguments and has to return a process object like from
 460 SB-EXT:RUN-PROGRAM.  The process also shouldn't be spawned with WAIT set.
 461
 462 DIRECTORIES is a list of directory arguments for WATCH/-RAW.
 463
 464 WAIT is only valid if FUNCTION is set.  If it is true, after FUNCTION has
 465 returned, we wait until the process has quit.
 466
 467 On supported implementations (SBCL) the FUNCTION parameter may be used to
 468 do some work while the program is running and watched by the inotify queue.
 469 It is called with the process object and the inotify queue as arguments."
 470   (let (events)
 471     (labels ((run ()
 472                (typecase program
 473                  (function (apply program args rest))
 474                  (T
 475                   (apply #'sb-ext:run-program program args :wait NIL rest))))
 476              (events (inotify)
 477                (do-events (event inotify)
 478                  (if event-handler
 479                      (funcall event-handler event)
 480                      (push event events))))
 481              (body (inotify)
 482                (unwind-protect
 483                     (progn
 484                       (let ((register (if registered #'watch #'watch-raw)))
 485                         (mapcar (lambda (directory)
 486                                   (funcall register inotify directory flags))
 487                                 directories))
 488                       (let ((process (run)))
 489                         (if function
 490                             (unwind-protect
 491                                  (funcall function process inotify)
 492                               ;; wait in any case so catching the files will work
 493                               (when wait
 494                                 (sb-ext:process-wait process)))
 495                             (loop
 496                               while (sb-ext:process-alive-p process)
 497                               do (events inotify)
 498                               finally (return (if event-handler
 499                                                   process
 500                                                   (values (nreverse events) process)))))))
 501                  (close-inotify inotify))))
 502       (let ((inotify (if registered (make-inotify) (make-unregistered-inotify))))
 503         (if function
 504             #-sbcl
 505             (error "the FUNCTION parameter is only supported on SBCL for now")
 506             #+sbcl
 507             (sb-sys:with-fd-handler
 508                 ((inotify-fd inotify)
 509                  :input
 510                  (lambda (handle)
 511                    (declare (ignore handle))
 512                    (events inotify)))
 513                 (body inotify))
 514             (body inotify))))))