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
   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: ~%")
 134     (list (read *query-io*))))
 135
 136 (eval-when (:compile-toplevel :load-toplevel :execute)
 137   (defun init-endian ()
 138     "Initialises the endianess for the BINARY-TYPES library.  Is automatically
 139 called when the library is loaded."
 140     (setf binary-types:*endian*
 141           (restart-case #+little-endian :little-endian
 142                         #+big-endian :big-endian
 143                         #-(or little-endian big-endian) (error "unknown endianess")
 144                         (use-value (value)
 145                           :report "Enter a correct value (either :LITTLE-ENDIAN or :BIG-ENDIAN)."
 146                           :interactive read-new-value
 147                           ;; TODO: better way to test for correct value/retry values?
 148                           (case value
 149                             ((:little-endian :big-endian) value)
 150                             (T (error "wrong value supplied (not :LITTLE-ENDIAN or :BIG-ENDIAN)"))))))))
 151
 152 ;; initialise the endianess
 153 (eval-when (:compile-toplevel :load-toplevel :execute)
 154   (init-endian))
 155
 156 ;;;; basic wrapping of the API
 157
 158 (defun read-raw-event-from-stream (stream)
 159   "Reads a raw event from the inotify stream."
 160   (let* ((event (binary-types:read-binary 'inotify-event stream))
 161          (len (binary-types:read-binary 'binary-types:u32 stream)))
 162     (when (plusp len)
 163       (with-slots (name) event
 164         (let ((buffer (make-array len :element-type '(unsigned-byte 8))))
 165           (read-sequence buffer stream :end len)
 166           (setf name (trivial-utf-8:utf-8-bytes-to-string buffer :end (position 0 buffer))))))
 167     event))
 168
 169 (defun read-event-from-stream (stream)
 170   "Reads a event from the inotify stream and converts bitmasks on reading."
 171   (let ((event (read-raw-event-from-stream stream)))
 172     (with-slots (mask) event
 173       (setf mask (foreign-bitfield-symbols 'inotify-flag mask)))
 174     event))
 175
 176 (defun set-nonblocking (fd nonblocking)
 177   "Enables or disables NONBLOCKING mode on a file descriptor FD."
 178   (let ((flags (sb-posix:fcntl fd sb-posix:f-getfl)))
 179     ;; an error is raised if this fails, so we don't have to do it ourselves
 180     (sb-posix:fcntl fd sb-posix:f-setfl
 181                     (funcall (if nonblocking #'logior #'logxor)
 182                              flags sb-posix:o-nonblock)))
 183   (values))
 184
 185 (defun init-unregistered-inotify (inotify &optional (nonblocking T))
 186   "Creates a new inotify event queue.  If NONBLOCKING is set (default),
 187 the file descriptor is set to non-blocking I/O."
 188   (let ((result (c-inotify-init)))
 189     (when (minusp result)
 190       (perror "inotify_init failed"))
 191     (with-slots (fd stream (non-block nonblocking)) inotify
 192       (unwind-protect
 193            ;; file descriptor is collected with auto-close
 194            (progn
 195              (setf fd result)
 196              (when nonblocking
 197                (set-nonblocking fd T)
 198                (setf non-block nonblocking))
 199              (setf stream
 200                    (sb-sys:make-fd-stream
 201                     fd
 202                     :input T
 203                     :element-type '(unsigned-byte 8)
 204                     :name (format NIL "inotify event queue ~A" fd)
 205                     :auto-close T
 206                     :buffering (if nonblocking :none :full))))
 207         ;; if stream is constructed, gc'ing it will cleanup the file descriptor
 208         (unless stream
 209           (sb-posix:close fd)))))
 210   inotify)
 211
 212 (defun make-unregistered-inotify ()
 213   "Creates a new unregistered INOTIFY instance."
 214   (init-unregistered-inotify (make-inotify-instance)))
 215
 216 (defun close-inotify (inotify)
 217   "Closes the inotify event queue."
 218   (close (inotify-stream inotify))
 219   (values))
 220
 221 (defun perror (prefix-string)
 222   #+sbcl (sb-int:simple-perror prefix-string)
 223   #-(or sbcl) (error prefix-string))
 224
 225 (defun ensure-list (arg)
 226   (if (listp arg) arg `(,arg)))
 227
 228 (defun translate-keyword-flags (flags)
 229   (typecase flags
 230     ((or keyword list)
 231      (foreign-bitfield-value 'inotify-flag (ensure-list flags)))
 232     (T flags)))
 233
 234 (defun watch-raw (inotify pathname flags)
 235   "Adds PATHNAME (either of type PATHNAME or STRING) to be watched.  FLAGS
 236 determines how exactly (see inotify(7) for detailed information) and can
 237 be of type LIST, KEYWORD or a raw numerical value (which isn't checked
 238 for validity though).  Returns a handle which can be used with UNWATCH-RAW."
 239   (let* ((path (etypecase pathname
 240                  (string pathname)
 241                  (pathname (namestring pathname))))
 242          (result (c-inotify-add-watch (inotify-fd inotify)
 243                                       path (translate-keyword-flags flags))))
 244     (when (minusp result)
 245       (perror "inotify_add_watch failed"))
 246     result))
 247
 248 (defun unwatch-raw (inotify handle)
 249   "Stops watching the path associated with a HANDLE established by WATCH-RAW."
 250   (let ((result (c-inotify-rm-watch (inotify-fd inotify) handle)))
 251     (when (minusp result)
 252       (perror "inotify_rm_watch failed")))
 253   (values))
 254
 255 ;;;; support functions, making life easier
 256
 257 (defstruct (registered-inotify-instance
 258              (:include inotify-instance)
 259              (:constructor make-registered-inotify-instance ())
 260              (:conc-name inotify-))
 261   "Additionally to the information in INOTIFY-INSTANCE, records watched
 262 paths in a dictionary."
 263   watched)
 264
 265 (defun make-inotify (&optional (nonblocking T))
 266   "Creates a new registered INOTIFY instance.  In NONBLOCKING mode, the file
 267 descriptor is set to non-blocking mode.  The resulting object has to be
 268 closed with CLOSE-INOTIFY."
 269   (let ((result (make-registered-inotify-instance)))
 270     (init-unregistered-inotify result nonblocking)
 271     (with-slots (watched) result
 272       (setf watched (make-hash-table :test 'equal)))
 273     result))
 274
 275 (defun pathname-handle/flags (inotify pathname)
 276   "Returns a CONS cell with the values HANDLE and FLAGS if PATHNAME is
 277 being watched by INOTIFY, else NIL.  The match is exact."
 278   (gethash pathname (inotify-watched inotify)))
 279
 280 (defun event-pathname/flags (inotify event &optional (handle (slot-value event 'wd)))
 281   "Returns two values PATHNAME and FLAGS for an EVENT which were used during
 282 registration.  If HANDLE is specified EVENT is ignored."
 283   (block NIL
 284     (maphash (lambda (pathname entry)
 285                (when (eql (car entry) handle)
 286                  (return (values pathname (cdr entry)))))
 287              (inotify-watched inotify))))
 288
 289 (defun sane-user-flags (inotify pathname flags &key (replace-p T))
 290   (check-type flags watch-flag-list)
 291   ;; now, :mask-add can't be member of flags
 292   ;; merge the flags
 293   (let* ((flags (ensure-list flags))
 294          (rep-flags (if replace-p
 295                         (cons :mask-add flags)
 296                         flags)))
 297     (let ((it (gethash pathname (slot-value inotify 'watched))))
 298       (if it
 299           (union (cdr it) rep-flags :test #'eq)
 300           rep-flags))))
 301
 302 (defun watch (inotify pathname flags &key (replace-p T))
 303   "Adds PATHNAME (either pathname or string) to be watched and records the
 304 watched paths.  FLAGS (a list of keywords) determines how exactly (see
 305 inotify(7) for detailed information).  Returns a handle which can be used
 306 with UNWATCH and EVENT-PATHNAME/FLAGS.  If REPLACE-P is set to T (default),
 307 the flags mask is replaced rather than OR-ed to the current mask (if it
 308 exists).  The :MASK-ADD flag is therefore removed from the FLAGS argument."
 309   (let* ((flags (sane-user-flags inotify pathname flags :replace-p replace-p))
 310          (handle (watch-raw inotify pathname flags)))
 311     (with-slots (watched) inotify
 312       (setf (gethash pathname watched) (cons handle flags)))
 313     handle))
 314
 315 (defun unwatch (inotify &key pathname event handle)
 316   "Disables watching the path associated with the supplied HANDLE (which
 317 may be one from a given EVENT) or PATHNAME."
 318   (unless (or pathname event handle)
 319     (error "either PATHNAME, EVENT or HANDLE have to be specified"))
 320   (when event
 321     (setf handle (slot-value event 'wd)))
 322   (if handle
 323       (unwatch-raw inotify handle)
 324       (let ((handle (car (pathname-handle/flags inotify pathname))))
 325         (unless handle
 326           (error "PATHNAME ~S isn't being watched" pathname))
 327         ;; remove even if unwatch-raw throws an error (which can happen if :oneshot is specified)
 328         (remhash pathname (inotify-watched inotify))
 329         (unwatch-raw inotify handle)))
 330   (values))
 331
 332 (defun list-watched (inotify)
 333   "Returns a LIST of all watched pathnames in no particular order."
 334   (loop
 335     for pathname being each hash-key in (inotify-watched inotify)
 336     collect pathname))
 337
 338 (defun unix-eagain-p (fd-stream)
 339   "Returns T on a FD-STREAM if trying to read from the stream raised a
 340 EAGAIN error."
 341   (multiple-value-bind (result error)
 342       (sb-unix:unix-read (sb-sys:fd-stream-fd fd-stream) NIL 0)
 343     (declare (ignore result))
 344     (= error sb-unix:eagain)))
 345
 346 (defun event-available-p (inotify)
 347   "Returns T if an event is available on the queue."
 348   (if (inotify-nonblocking inotify)
 349       (not (unix-eagain-p (inotify-stream inotify)))
 350       (listen (inotify-stream inotify))))
 351
 352 (defun read-event (inotify)
 353   "Reads an event from the queue.  Blocks if no event is available."
 354   (read-event-from-stream (inotify-stream inotify)))
 355
 356 (defun next-event (inotify)
 357   "Reads an event from the queue.  Returns NIL if none is available."
 358   (when (event-available-p inotify)
 359     (read-event inotify)))
 360
 361 (defmacro do-events ((var inotify &key blocking-p) &body body)
 362   "Loops BODY with VAR bound to the next events retrieved from INOTIFY.
 363 The macro uses NEXT-EVENT, so reading an event won't block and the loop
 364 terminates if no events are available."
 365   (check-type var symbol)
 366   (let ((inotify-sym (gensym)))
 367    `(loop
 368       with ,var and ,inotify-sym = ,inotify
 369       ,.(unless blocking-p
 370           `(while (event-available-p ,inotify-sym)))
 371       do (progn
 372            (setf ,var (read-event ,inotify-sym))
 373            ,.body))))
 374
 375 (defun next-events (inotify)
 376   "Reads all available events from the queue.  Returns a LIST of events."
 377   (loop
 378     while (event-available-p inotify)
 379     collect (read-event inotify)))