;;; HFS+ extended attribute interface

;; Copyright (c) 2009 Jim Ursetto.  All Rights Reserved.
;; License: BSD.  However, see copyfile.h, which is included
;; in this distribution, and is under the APSL.

#> #include <sys/xattr.h>
   /* copyfile.h can be obtained from
    * http://www.opensource.apple.com/source/Libc/Libc-391.5.18/darwin/copyfile.h */
   #include "copyfile.h"
   #include <errno.h>
<#

;; list-extended-attributes returns a list of strings.  get-* and set-*
;; accept a string or symbol as a key.  get-extended-attributes returns
;; keys as symbols.

;; If attribute key or value changes size between calls to determine
;; size of buffer, we will return the smaller buffer or retry the call if larger.

(declare
 (disable-interrupts)   ; solely for errno
 )

(module hfs+
 (list-extended-attributes
  get-extended-attribute set-extended-attribute!
  remove-extended-attribute!
  get-extended-attributes
  clear-extended-attributes!
  copyfile copyfile-check
  pack-appledouble unpack-appledouble)

(import scheme chicken foreign)
(import (only data-structures string-split))
(import foreigners)

;; ssize_t listxattr(const char *path, char *namebuf, size_t size, int options);
;; ssize_t flistxattr(int fd, char *namebuf, size_t size, int options);
(define listxattr
  (foreign-lambda int listxattr (const c-string) scheme-pointer int int))
(define flistxattr
  (foreign-lambda int flistxattr int scheme-pointer int int))

;; ssize_t getxattr(const char *path, const char *name, void *value, size_t size,
;;                  u_int32_t position, int options);
(define getxattr
  (foreign-lambda int getxattr (const c-string) (const c-string) scheme-pointer int
                  int int))
(define fgetxattr
  (foreign-lambda int fgetxattr int (const c-string) scheme-pointer int
                  int int))

;; int setxattr(const char *path, const char *name, void *value, size_t size,
;;              u_int32_t position, int options);
(define setxattr
  (foreign-lambda int setxattr (const c-string) (const c-string) scheme-pointer int
                  int int))
(define fsetxattr
  (foreign-lambda int fsetxattr int (const c-string) scheme-pointer int
                  int int))

;; int removexattr(const char *path, const char *name, int options);
(define removexattr
  (foreign-lambda int removexattr (const c-string) (const c-string) int))
(define fremovexattr
  (foreign-lambda int fremovexattr int (const c-string) int))

(define _copyfile
  (foreign-lambda int copyfile (const c-string) (const c-string) c-pointer int))

(define-foreign-enum-type (xattr-options int)
  (xattr-options->int int->xattr-options)
  ((no-follow xattr/nofollow) XATTR_NOFOLLOW)
  ((create xattr/create) XATTR_CREATE)
  ((replace xattr/replace) XATTR_REPLACE)
  ((silent xattr/silent) "0")  ; hack -- not a real API option :)
  )

(define-foreign-enum-type (copyfile-options int)
  (copyfile-options->int int->copyfile-options)
  ((acl copyfile/acl) COPYFILE_ACL)
  ((stat copyfile/stat) COPYFILE_STAT)
  ((xattr copyfile/xattr) COPYFILE_XATTR)
  ((data copyfile/data) COPYFILE_DATA)
  ((security copyfile/security) COPYFILE_SECURITY)
  ((metadata copyfile/metadata) COPYFILE_METADATA)
  ((all copyfile/all) COPYFILE_ALL)
  ((check copyfile/check) COPYFILE_CHECK)
  ((pack copyfile/pack) COPYFILE_PACK)
  ((unpack copyfile/unpack) COPYFILE_UNPACK)
  ((exclusive copyfile/excl) COPYFILE_EXCL)
  ((no-follow-source copyfile/no-follow-source) COPYFILE_NOFOLLOW_SRC)
  ((no-follow-dest copyfile/no-follow-dest) COPYFILE_NOFOLLOW_DST)
  ((move copyfile/move) COPYFILE_MOVE)
  ((unlink copyfile/unlink) COPYFILE_UNLINK)
  ((no-follow copyfile/no-follow) COPYFILE_NOFOLLOW)
;;   ((silent copyfile/silent) "0")  ; hack -- not a real API option :)
  )

(define strerror
  (foreign-lambda c-string strerror int))
;; Warning: A SRFI-18 thread might change errno from under us (but we still detect the error).
(define (xattr-error rc loc . args)
  (signal
   (make-composite-condition
    (make-property-condition 'exn 'location loc 'message (strerror rc) 'arguments args)
    (make-property-condition 'file)
    (make-property-condition 'hfs+ 'errno rc))))

(define (update-errno)
  (##sys#update-errno))
(define errno/range (foreign-value "ERANGE" int))
(define errno/noattr (foreign-value "ENOATTR" int))
(define errno/exist (foreign-value "EEXIST" int))

;;; Base API - Extended attributes

;; Accepted options: #:no-follow (or 'no-follow) to prevent following symlink; if passing
;; a file descriptor, it is illegal to specify this option.
(define (list-extended-attributes file . options)
  (let ((c-options (xattr-options->int options))      ; #:create or #:replace is ignored
        (listxattr (if (number? file)
                       flistxattr
                       listxattr)))
    (let retry ()
      (let ((size (listxattr file #f 0 c-options)))
        (cond ((< size 0)
               (xattr-error (update-errno) 'list-extended-attributes file))
              ((= size 0)
               '())
              (else
               (let* ((buf (make-string size))
                      (new-size (listxattr file buf size c-options)))
                 (cond ((< new-size 0)
                        (let ((err (update-errno)))
                          (if (= err errno/range)    ; length increased since we called
                              (retry)
                              (xattr-error err 'list-extended-attributes file))))
                       ((< new-size size)            ; length decreased since we called
                        (string-split (substring buf 0 new-size) "\x00"))
                       (else
                        (string-split buf "\x00") )))))))))

;; Returns #f if attribute does not exist.  Signals an error
;; on any other getxattr failure, including file not found.
(define (get-extended-attribute file attribute . options)
  (let ((c-options (xattr-options->int options))
        (offset 0)
        (getxattr (if (number? file)
                       fgetxattr
                       getxattr))
        (attribute (if (symbol? attribute)
                       (symbol->string attribute)
                       attribute)))
    (let retry ()
      (let ((size (getxattr file attribute #f 0 offset c-options)))
        (cond ((< size 0)
               (let ((err (update-errno)))
                 (cond ((= err errno/noattr)
                        #f)
                       (else
                        (xattr-error err 'get-extended-attribute
                                     file attribute)))))
              ((= size 0)
               "")
              (else
               (let* ((buf (make-string size))
                      (new-size (getxattr file attribute buf
                                          size offset c-options)))
                 (cond ((< new-size 0)
                        (let ((err (update-errno)))
                          (cond ((= err errno/noattr) #f)
                                ((= err errno/range)  (retry))
                                (else
                                 (xattr-error err 'get-extended-attribute
                                              file attribute)))))
                       ((< new-size size) ; length decreased since we called
                        (substring buf 0 new-size))
                       (else
                        buf)))))))))

;; #:silent could, possibly, fail silently on errno/noattr or errno/exist.
(define (set-extended-attribute! file attribute value . options)
  (let ((c-options (xattr-options->int options))  ; 'create + 'replace results in EINVAL
        (offset 0)
        (setxattr (if (number? file)
                      fsetxattr
                      setxattr))
        (attribute (if (symbol? attribute)
                       (symbol->string attribute)
                       attribute)))
    (let ((size (cond ((blob? value) (blob-size value))
                      ((string? value) (string-length value))
                      (else (error 'set-extended-attribute!
                                   "value must be a string or blob")))))
      (let ((rv (setxattr file attribute value size offset c-options)))
        (cond ((< rv 0)
               (let ((err (update-errno)))
                 (cond ((= err errno/noattr)
                        (error 'set-extended-attribute!
                               "attribute not found" attribute))
                       ((= err errno/exist)   ;; EEXIST is confusing
                        (error 'set-extended-attribute!
                               "attribute already exists" attribute))
                       (else
                        (xattr-error err 'set-extended-attribute!
                                     file attribute)))))
              ((> rv 0)
               (error 'set-extended-attribute!
                      "unexpected return value" rv))
              (else
               (void)))))))

;; Error signaled if attribute does not exist, but if you give the
;; #:silent option it will fail silently.
(define (remove-extended-attribute! file attribute . options)
  (let ((c-options (xattr-options->int options))
        (attribute (if (symbol? attribute)
                       (symbol->string attribute)
                       attribute))
        (removexattr (if (number? file)
                         fremovexattr
                         removexattr)))
    (let ((rv (removexattr file attribute c-options)))
      (cond ((< rv 0)
             (let ((err (update-errno)))
               (if (and (= err errno/noattr)
                        (memq #:silent options))
                   (void)
                   (xattr-error err 'remove-extended-attribute! file attribute))))
            ((> rv 0)
             (error 'remove-extended-attribute!
                    "unexpected return value" rv))
            (else
             (void))))))

;;; Base API - Copyfile

;; [copyfile is not officially supported on Tiger and, although metadata pack/unpack
;;  to AppleDouble files seems to work fine, copying actual data via #:data or #:all
;;  will throw a spurious error or crash.  #:move doesn't seem to work, but #:excl does.
;;  #:no-follow is ignored for packing (critical) and unpacking (not).]

;; Copies FROM file to TO file using OS X copyfile(3) API,
;; preserving HFS+ metadata as specified in copyfile OPTIONS.
(define (copyfile from to . options)
  (let ((c-options (copyfile-options->int options)))
    (let ((rv (_copyfile from to #f c-options)))
      (cond ((< rv 0)
             (xattr-error (update-errno) 'copyfile
                          from to))
            (else rv)))))

;;; Utilities

;; Returns an alist mapping attribute name (symbol) to value (string).
;; Possible optimization: If passed a filename, and #:nofollow is not specified,
;; we can open it and reuse the fd. (And must unwind-protect to close fd.)
(define (get-extended-attributes file . options)
  (map (lambda (a)
         (cons (string->symbol a)
               (apply get-extended-attribute file a options)))
       (apply list-extended-attributes file options)))

(define (clear-extended-attributes! file . options)
  (for-each
   (lambda (x)
     (apply remove-extended-attribute! file x options))
   (apply list-extended-attributes file options)))

;; (define (get-resource-fork filename)
;;   ...)

;; Pack/unpack all HFS+ metadata (xattrs, acls, POSIX stat).  If no
;; error occurs, pack returns #f when no metadata was present (and
;; does not write a file) or #t if metadata was present (and a file is
;; written).  Unpack always returns #t.  Extra options are passed into
;; copyfile; relevant ones might be #:excl, #:move and #:no-follow,
;; although #:move and #:no-follow do not work correctly under Tiger.
(define (pack-appledouble from to . options)
  (if (= 0 (apply copyfile from #f #:check #:metadata options))
      #f
      (and (apply copyfile from to #:pack #:metadata options) #t)))
(define (unpack-appledouble from to . options)
  (and (apply copyfile from to #:unpack #:metadata options) #t))

;; Return a list of symbols denoting the attributes that WOULD be
;; copied from the FROM file, according to the OPTIONS provided.
;; Example call: (copyfile-check "foo.txt" #:metadata)
;; Example return: '(acl stat extended-attributes) meaning
;; COPYFILE_ACL, COPYFILE_STAT, COPYFILE_XATTR.
(define (copyfile-check from . options)
  (let ((options (cons 'check options)))
    (let ((rv (apply copyfile from #f options)))
      (cond ((= rv 0) '())
            ((> rv 0)
             ;; enumtypes won't decompose into their component bitfields
             ;; we could also case all 8 possibilities
             `(,@(if (= 0 (bitwise-and rv copyfile/acl)) '() '(acls))
               ,@(if (= 0 (bitwise-and rv copyfile/stat)) '() '(stat))
               ,@(if (= 0 (bitwise-and rv copyfile/xattr)) '() '(extended-attributes))))
            (else (error 'copyfile-check "unexpected copyfile return value" rv))))))

)