inotify.lisp

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