;;; -*- Mode: Scheme -*-

;;;; Unix File Descriptors

;;; Copyright (c) 2009, Taylor R. Campbell
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; * Redistributions of source code must retain the above copyright
;;;   notice, this list of conditions and the following disclaimer.
;;;
;;; * Redistributions in binary form must reproduce the above copyright
;;;   notice, this list of conditions and the following disclaimer in
;;;   the documentation and/or other materials provided with the
;;;   distribution.
;;;
;;; * Neither the names of the authors nor the names of contributors
;;;   may be used to endorse or promote products derived from this
;;;   software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(begin-c-stub "unix-fd")

(c-system-include "sys/types.h")

(c-system-include "errno.h")
(c-system-include "string.h")
(c-system-include "unistd.h")

(define-record-type <file-descriptor>
    (make-file-descriptor alien)
    file-descriptor?
  (alien file-descriptor.alien set-file-descriptor.alien!))

(define file-descriptor-finalizer
  (make-default-finalizer
   (lambda (alien) (%close-file-descriptor alien))
   (lambda (object) (file-descriptor? object))
   (lambda (file-descriptor alien)
     (set-file-descriptor.alien! file-descriptor alien))))

(define-unix-syscall (%close-file-descriptor
                      (fd-pointer (c-alien-pointer "int")))
  (c-begin "if ((*fd_pointer) >= 0)                                     "
           "  {                                                         "
           "    SCHEME_VOID_SYSCALL (close, (close (*fd_pointer)));     "
           "    (*fd_pointer) = (-1);                                   "
           "  }                                                         "
           (c-unspecific)))

(define (file-descriptor-closed? file-descriptor)
  (let ((alien (file-descriptor.alien file-descriptor)))
    (or (not alien) (< (alien->integer alien) 0))))

(define (file-descriptor-numbered? file-descriptor integer)
  (let ((alien (file-descriptor.alien file-descriptor)))
    (and alien (= integer (alien->integer alien)))))

(define-c (integer->alien (integer (c-integral "int")))
  (c-alien "int" "integer"))

(define-c (alien->integer (alien "integer" (c-alien "int")))
  (c-integral "int" "integer"))

(define file-descriptor-map-mutex
  (make-recursive-mutex))

;;; This maps integers to file descriptors.  If Scheme has a record for
;;; some integer, then this maps the integer to that record; otherwise,
;;; this may have no association for the integer, or it may map the
;;; integer to a different record, which should be ignored.

(define file-descriptor-map
  (make-tail-weak-integer-hash-map))

(define-syntax with-file-descriptor-aliens
  (syntax-rules ()
    ((WITH-FILE-DESCRIPTOR-ALIENS ((file-descriptor-variable alien-variable)
                                   ...)
         initialization
       body0 body1+ ...)
     (LET ((INITIALIZER (LAMBDA (alien-variable ...) initialization))
           (BODY (LAMBDA (file-descriptor-variable ...) body0 body1+ ...)))
       (LET ((alien-variable (INTEGER->ALIEN -1)) ...)
         (LET ((file-descriptor-variable (MAKE-FILE-DESCRIPTOR alien-variable))
               ...)
           (FINALIZER/ADD-OBJECT! FILE-DESCRIPTOR-FINALIZER
                                  file-descriptor-variable
                                  alien-variable)
           ...
           (INITIALIZER alien-variable ...)
           (INITIALIZE-FILE-DESCRIPTOR! file-descriptor-variable)
           ...
           (BODY file-descriptor-variable ...)))))))

(define (initialize-file-descriptor! file-descriptor)
  (let ((integer (alien->integer (file-descriptor.alien file-descriptor))))
    (if (>= integer 0)
        (with-recursive-mutex-locked file-descriptor-map-mutex
          (lambda ()
            (%allocate-file-descriptor integer file-descriptor))))))

(define (%allocate-file-descriptor integer file-descriptor)
  (hash-map/update! file-descriptor-map integer
    (lambda (file-descriptor* replace delete)
      delete                            ;ignore
      (if (file-descriptor-numbered? file-descriptor* integer)
          (error "File descriptor already allocated:"
                 file-descriptor
                 file-descriptor*)
          (replace file-descriptor)))
    (lambda (insert)
      (insert file-descriptor))))

;;; Use OPEN-FILE-DESCRIPTOR for Scheme to take responsibility for a
;;; file descriptor interruptwise atomically, by passing a pointer into
;;; the alien to C code for it to initialize.

(define (open-file-descriptor procedure)
  (with-file-descriptor-aliens ((file-descriptor alien))
      (procedure alien)
    file-descriptor))

;;; MAYBE-INTEGER->FILE-DESCRIPTOR returns the file descriptor record
;;; for a file descriptor number, if Scheme has responsibility for it
;;; and it has not been lost because of an interrupt; or else returns
;;; #F.  #F does not mean that the file descriptor is unallocated by
;;; the operating system, however.  INTEGER->FILE-DESCRIPTOR takes an
;;; integer that has been allocated by the operating system but for
;;; which no one is responsible (!), and makes Scheme responsible.

(define (maybe-integer->file-descriptor integer)
  (guarantee-file-descriptor-number integer 'MAYBE-INTEGER->FILE-DESCRIPTOR)
  (let ((file-descriptor
         (with-recursive-mutex-locked file-descriptor-map-mutex
           (lambda ()
             (hash-map/lookup file-descriptor-map integer #f)))))
    (and file-descriptor
         (file-descriptor-numbered? file-descriptor integer)
         file-descriptor)))

(define (integer->file-descriptor integer)
  (guarantee-file-descriptor-number integer 'INTEGER->FILE-DESCRIPTOR)
  (with-recursive-mutex-locked file-descriptor-map-mutex
    (lambda ()
      (define (if-not-found insert)
        (let* ((alien (integer->alien integer))
               (file-descriptor (make-file-descriptor alien)))
          (finalizer/add-object! file-descriptor-finalizer
                                 file-descriptor
                                 alien)
          (insert file-descriptor)
          file-descriptor))
      (hash-map/update! file-descriptor-map integer
        (lambda (file-descriptor replace delete)
          delete                        ;ignore
          (if (file-descriptor-numbered? file-descriptor integer)
              file-descriptor
              (if-not-found replace)))
        if-not-found))))

;;; Use CALL-WITH-FILE-DESCRIPTOR-NUMBER if you need to use the number
;;; of the file descriptor (e.g., to make some system calls with it),
;;; but need Scheme to retain responsibility for it.

(define (call-with-file-descriptor-number file-descriptor receiver)
  (define (lose) (error "File descriptor is closed:" file-descriptor))
  (let ((alien (file-descriptor.alien file-descriptor)))
    (if (not alien) (lose))
    (let ((integer (alien->integer alien)))
      (if (< integer 0) (lose))
      (with-object-referenced file-descriptor
        (lambda ()
          (receiver integer))))))

;;; Use CALL-WITH-FILE-DESCRIPTOR-ALIEN if you need Scheme to cede
;;; responsibility for the file descriptor (e.g., to make a stdio file
;;; stream or an OpenSSL BIO, which takes responsibility for it), and
;;; perhaps take responsibility for a new one.  You don't need to
;;; replace the integer stored in the alien, but if you do, you must do
;;; it interruptwise atomically in C; replace it by -1 to cede it.

(define (call-with-file-descriptor-alien file-descriptor receiver)
  (call-with-file-descriptor-alien&number file-descriptor
    (lambda (alien integer)
      integer                           ;ignore
      (receiver alien))))

(define (call-with-file-descriptor-alien&number file-descriptor receiver)
  (define (lose) (error "File descriptor is closed:" file-descriptor))
  (let ((alien (file-descriptor.alien file-descriptor)))
    (if (not alien) (lose))
    (let ((integer (alien->integer alien)))
      (if (< integer 0) (lose))
      (receive results (receiver alien integer)
        (let ((integer* (alien->integer alien)))
          (if (not (= integer integer*))
              (with-recursive-mutex-locked file-descriptor-map-mutex
                (lambda ()
                  (%deallocate-file-descriptor integer file-descriptor)
                  (if (>= integer* 0)
                      (%allocate-file-descriptor integer* file-descriptor))))))
        (apply values results)))))

(define (close-file-descriptor file-descriptor)
  (let ((alien (file-descriptor.alien file-descriptor)))
    (if alien
        (let ((integer (alien->integer alien)))
          (if (>= integer 0)
              (begin
                (finalizer/remove-object! file-descriptor-finalizer
                                          file-descriptor)
                (with-recursive-mutex-locked file-descriptor-map-mutex
                  (lambda ()
                    (%deallocate-file-descriptor integer
                                                 file-descriptor)))))))))

(define (%deallocate-file-descriptor integer file-descriptor)
  (hash-map/update! file-descriptor-map integer
    (lambda (file-descriptor* replace delete)
      replace                           ;ignore
      (if (eq? file-descriptor* file-descriptor)
          (delete)))
    (lambda (insert)
      insert                            ;ignore
      (values))))

(define (duplicate-file-descriptor file-descriptor)
  (call-with-file-descriptor-number file-descriptor
    (lambda (number)
      (open-file-descriptor (lambda (alien) (%dup number alien))))))

(define-unix-uint-syscall*
    (%dup (fd (c-integral "int"))
          (fd-pointer (c-alien-pointer "int")))
  (c-declare)
  (c-begin)
  (=> "int" "new_fd")
  ("dup" "fd")
  (c-void "(*fd_pointer) = new_fd;"))

;;; DUPLICATE-FILE-DESCRIPTOR-TO leaves Scheme with responsibility for
;;; two file descriptors.  If you just want to a file descriptor with a
;;; different number from the one you began with, discarding the old
;;; one, use RENUMBER-FILE-DESCRIPTOR below.

(define (duplicate-file-descriptor-to file-descriptor number)
  (guarantee-file-descriptor-number number 'DUPLICATE-FILE-DESCRIPTOR-TO)
  (call-with-file-descriptor-number file-descriptor
    (lambda (original-number)
      (if (= number original-number)
          file-descriptor
          (%duplicate-file-descriptor-to original-number number)))))

(define (%duplicate-file-descriptor-to original-number number)
  (with-recursive-mutex-locked file-descriptor-map-mutex
    (lambda ()
      (define (if-not-found insert)
        ;; We know a priori what the number will be, but we don't want
        ;; to store it in the finalizer until we know that the
        ;; operating system has allocated it, i.e. after the call to
        ;; dup2.  So we put an alien with -1 in the finalizer and then
        ;; store the correct number in the alien in %DUP2.  This is
        ;; different from what INTEGER->FILE-DESCRIPTOR does, because
        ;; INTEGER->FILE-DESCRIPTOR is an unsafe operation anyway.
        (let* ((alien (integer->alien -1))
               (file-descriptor (make-file-descriptor alien)))
          (finalizer/add-object! file-descriptor-finalizer
                                 file-descriptor
                                 alien)
          (%dup2 original-number number alien)
          (insert file-descriptor)
          file-descriptor))
      (hash-map/update! file-descriptor-map number
        (lambda (file-descriptor* replace delete)
          delete                        ;ignore
          (if (file-descriptor-numbered? file-descriptor* number)
              (error "File descriptor number already allocated:" number)
              (if-not-found replace)))
        if-not-found))))

(define-unix-void-syscall
    (%dup2 (source-fd (c-integral "int"))
           (target-fd (c-integral "int"))
           (fd-pointer (c-alien-pointer "int")))
  ("dup2" "source_fd" "target_fd")
  (c-void "(*fd_pointer) = target_fd;"))

(define (renumber-file-descriptor file-descriptor number)
  (guarantee-file-descriptor-number number 'RENUMBER-FILE-DESCRIPTOR)
  (call-with-file-descriptor-number file-descriptor
    (lambda (original-number)
      (if (= original-number number)
          file-descriptor
          (let ((file-descriptor*
                 (%duplicate-file-descriptor-to original-number number)))
            (close-file-descriptor file-descriptor)
            file-descriptor*)))))

;; (define (renumber-file-descriptor! file-descriptor number)
;;   (guarantee-file-descriptor-number number 'RENUMBER-FILE-DESCRIPTOR!)
;;   (call-with-file-descriptor-alien&number file-descriptor
;;     (lambda (alien original-number)
;;       (if (not (= original-number number))
;;           (%dup2-and-close original-number number alien)))))

(define (renumber-file-descriptor! file-descriptor number)
  (define (lose) (error "File descriptor is closed:" file-descriptor))
  (guarantee-file-descriptor-number number 'RENUMBER-FILE-DESCRIPTOR!)
  (let ((alien (file-descriptor.alien file-descriptor)))
    (if (not alien) (lose))
    (let ((original-number (alien->integer alien)))
      (if (< original-number 0) (lose))
      (if (not (= original-number number))
          (with-recursive-mutex-locked file-descriptor-map-mutex
            (lambda ()
              (define (if-not-found insert)
                (%dup2-and-close original-number number alien)
                (insert file-descriptor)
                (%deallocate-file-descriptor original-number file-descriptor))
              (hash-map/update! file-descriptor-map number
                (lambda (file-descriptor* replace delete)
                  delete                ;ignore
                  (if (file-descriptor-numbered? file-descriptor* number)
                      (error "File descriptor number already allocated:"
                             number)
                      (if-not-found replace)))
                if-not-found)))))))

(define-unix-syscall (%dup2-and-close
                      (source-fd (c-integral "int"))
                      (target-fd (c-integral "int"))
                      (fd-pointer (c-alien-pointer "int")))
  (c-begin
    "SCHEME_VOID_SYSCALL (dup2, (dup2 (source_fd, target_fd))); "
    "(*fd_pointer) = target_fd;                                 "
    "SCHEME_VOID_SYSCALL (close, (close (source_fd)));          "
    (c-unspecific)))

(define (open-pipe)
  (with-file-descriptor-aliens ((reader-fd reader-alien)
                                (writer-fd writer-alien))
      (%open-pipe reader-alien writer-alien)
    (values reader-fd writer-fd)))

(define-unix-void-syscall
    (%open-pipe (reader-fd-pointer (c-alien-pointer "int"))
                (writer-fd-pointer (c-alien-pointer "int")))
  (c-declare "int fds [2];")
  ("pipe" "fds")
  (c-begin
    "(*reader_fd_pointer) = (fds [0]);"
    "(*writer_fd_pointer) = (fds [1]);"
    (c-unspecific)))

(define (exact-nonnegative-integer? object)
  (and (integer? object)
       (exact? object)
       (>= object 0)))

(define (guarantee-file-descriptor-number object caller)
  (if (not (exact-nonnegative-integer? object))
      (error "Not a file descriptor number:" object caller)))

(end-c-stub)