inotify.lisp

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