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