things/fs-at.scm

;;;; (fs-at) -- *at FFI bindings for Guile
;;;;
;;;;    Copyright (C) 2021 Maxime Devos <maximedevos at telenet dot be>
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 U>

(define-module (fs-at)
  #:use-module (srfi srfi-8)
  #:use-module (srfi srfi-9)
  #:use-module (system foreign)
  #:export (make-path-at path-at?)
  #:replace ((new-open . open)
	     (new-chmod . chmod)
	     (new-chown . chown)
	     (new-stat . stat)
	     (new-lstat . lstat)
	     (new-mkdir . mkdir)
	     (new-mknod . mknod)))

;; TODO write basic tests for each procedure,
;; to make sure the C API is bound correctly
;; for each (system, architecture)

;; TODO lstat, stat is untested

;; TODO only x86-64, Linux is currently supported


;; Raw C bindings
(define libc (dynamic-link))

;; XXX check if this is always true.
(define mode_t int)
(define dev_t int)
(define uid_t int)
(define gid_t int)

;; XXX more check non-x86-64, Hurd
(define ino64_t uint64)
(define blkcnt64_t uint64)
(define syscall_ulong_t uint64)
(define syscall_slong_t int64)

(define off_t syscall_slong_t)
(define nlink_t syscall_ulong_t)
(define time_t syscall_slong_t)
(define blksize_t syscall_ulong_t)

;; XXX Depends on system
;; Maybe different on the Hurd
(define MKNOD_VER 0)
(define STAT_VER 1)

(define c:openat
  (pointer->procedure int
		      (dynamic-func "openat" libc)
		      (list int '* int mode_t)
		      #:return-errno? #t))
(define c:fchmodat
  (pointer->procedure int
		      (dynamic-func "fchmodat" libc)
		      (list int '* mode_t int)
		      #:return-errno? #t))

(define c:fchownat
  (pointer->procedure int
		      (dynamic-func "fchownat" libc)
		      (list int '* uid_t gid_t int)
		      #:return-errno? #t))

(define c:mkdirat
  (pointer->procedure int
		      (dynamic-func "mkdirat" libc)
		      (list int '* mode_t)
		      #:return-errno? #t))

;; Assumes glibc (and maybe Linux? XXX verify)
(define c:mknodat
  (let ((c:__xmknodat
	 (pointer->procedure int
			     (dynamic-func "__xmknodat" libc)
			     (list int int '* mode_t '*)
			     #:return-errno? #t)))
    (lambda (fd path mode dev)
      (let ((dev-ptr (make-c-struct (list dev_t) (list dev))))
	(c:__xmknodat MKNOD_VER fd path mode dev-ptr)))))


;; XXX
;; While compiling expression:
;; In procedure dynamic-pointer: Symbol not found: fstatat

(define c:fstatat/1
  (let ((c:__fstatat
	 (pointer->procedure int
			     (dynamic-func "__fxstatat64" libc)
			     (list int int '* '* int)
			     #:return-errno? #t)))
    (lambda (fd filename statbuf flags)
      (c:__fstatat STAT_VER fd filename statbuf flags))))


;; Scheme wrappers, using ports.
;;
;; Be careful not to lose fds before the port
;; has been created.

(define (call-with-fd port proc)
  "Call PROC with the fd of PORT."
  ;; call-with-blocked-asyncs:
  ;; prevent leaking file descriptors if interrupted
  (let ((fd (fileno port)))
    (call-with-blocked-asyncs
     (lambda ()
       (dynamic-wind
	 (lambda ()
	   (set-port-revealed! port
			       (+ 1 (port-revealed port))))
	 (lambda ()
	   (call-with-unblocked-asyncs
	    (lambda () (proc fd))))
	 (lambda ()
	   (release-port-handle port)))))))

(define-syntax-rule (with-fd port fd exp exp* ...)
  (call-with-fd port (lambda (fd) exp exp* ...)))

;; XXX maybe set-port-filename!,
;; but be careful with symbolic links
;; and relative names (".", "..").

;; XXX guile doesn't check for #\0 in filenames,
;; verify at #guile whether that is expected.
;; (Maybe there are performance reasons.)
;; For consistency with guile (and laziness), this module
;; reproduces this maybe-a-bug.

(define (errno-error subr errno)
  (scm-error 'system-error subr (strerror errno) '() (list errno)))

;; *at wrappers using Scheme types
(define (chownat fd-port file-name uid gid flags)
  (with-fd fd-port fd
	   (receive (result errno)
	       (c:fchownat fd (string->pointer file-name) uid gid flags)
	     (unless (= result 0)
	       (errno-error "chown" errno)))))

(define (chmodat fd-port file-name mode flags)
  (with-fd fd-port fd
	   (receive (result errno)
	       (c:fchmodat fd (string->pointer file-name) mode flags)
	     (unless (= result 0)
	       (errno-error "chmod" errno)))))

(define (mode->modes mode)
  (cond ((= mode O_RDWR) "rw0")
	((= mode O_RDONLY) "r0")
	((= mode O_WRONLY) "w0")
	;; What madness is this? XXX what would be appropriate here?
	(#t "r0")))

;; Note: the ‘flags’ and ‘mode’ argument order
;; difers between openat(2) and chmodat(2).
(define (openat fd-port file-name flags mode)
  (with-fd fd-port fd
	   ((call-with-blocked-asyncs
	     (lambda ()
	       (receive (result errno)
		   (c:openat fd (string->pointer file-name) flags mode)
		 (if (>= result 0)
		     (let ((port (fdopen result (mode->modes mode))))
		       (lambda () port))
		     (lambda ()
		       (errno-error "open" errno)))))))))

(define (mkdirat fd-port filename mode)
  (receive (result errno)
      (with-fd fd-port fd
	       (c:mkdirat fd (string->pointer filename) mode))
    (unless (= result 0)
      (errno-error "mkdir" errno))))

(define (mknodat fd-port filename mode dev)
  (receive (result errno)
      (with-fd fd-port fd
	       (c:mknodat fd (string->pointer filename) mode dev))
    (unless (= result 0)
      (errno-error "mknod" errno))))

(define stat64
  (cond ((and (string-prefix? "x86_64-" %host-type)
	      (string-contains %host-type "-linux"))
	 (list dev_t
	       ino64_t nlink_t mode_t
	       uid_t gid_t
	       int dev_t off_t
	       blksize_t blkcnt64_t
	       time_t syscall_ulong_t
	       time_t syscall_ulong_t
	       time_t syscall_ulong_t
	       syscall_slong_t syscall_slong_t syscall_slong_t))
	(else ???)))

(define statbuf->vector
  (let ((for-this-architecture
	 (cond ((and (string-prefix? "x86_64-" %host-type)
		     (string-contains %host-type "-linux"))
		(lambda (dev
			 ino nlink mode
			 uid gid
			 pad0 rdev size
			 blksize blocks
			 atime atimensec
			 mtime mtimensec
			 ctime ctimensec
			 reserved0 reserved1 reserved2)
		  `#(,dev
		     ,ino
		     ,mode
		     ,nlink
		     ,uid
		     ,gid
		     ,rdev
		     ,size
		     ,atime
		     ,mtime
		     ,ctime
		     ,blksize
		     ,blocks
		     ,(mode->type mode)
		     ,(mode->perms mode)
		     ,atimensec
		     ,mtimensec
		     ,ctimensec)))
	       ;; XXX other architectures and systems
	       (#t ???))))
    (lambda (struct-pointer)
      (apply for-this-architecture
	     (parse-c-struct struct-pointer stat64)))))

(define (fstatat fd-port filename flags)
  (let ((statbuf (make-c-struct stat64 (map (const 0) stat64))))
    (receive (result errno)
	(with-fd fd-port fd
		 ;; filename = #f/"\0" can be used with AT_EMPTY_PATH
		 (c:fstatat/1 fd (string->pointer (or filename ""))
			      statbuf flags))
      (if (= result 0)
	  (statbuf->vector statbuf)
	  (errno-error "stat" errno)))))



;; Scheme
;;
;;   XXX the directory should not be closed as long
;;   as <path-at> objects are used.
;;
;;   Warning: most procedures will still dereference
;;   the symbolic link (if any)
(define-record-type <path-at>
  (%make-path-at directory filename)
  path-at?
  (directory path-at-directory)
  (filename path-at-filename))

(define (make-path-at directory filename)
  ;; XXX verify arguments
  (%make-path-at directory filename))

(define new-open
  (case-lambda
    ((object flags) (new-open object flags #o666))
    ((object flags mode)
     (if (path-at? object)
	 (openat (path-at-directory object) (path-at-filename object)
		 flags mode)
	 (open object flags mode)))))

(define (new-chmod object mode)
  (if (path-at? object)
      (chmodat (path-at-directory object) (path-at-filename object)
	       mode
	       0)
      (chmod object mode)))

(define (new-chown object owner group)
  (if (path-at? object)
      (chownat (path-at-directory object) (path-at-filename object)
	       owner group
	       0)
      (chown object owner group)))

(define (new-lstat object)
  (cond ((path-at? object)
	 (fstatat (path-at-directory object) (path-at-filename object)
		  AT_SYMLINK_NOFOLLOW))
	((port? object)
	 (fstatat object #f (logior AT_EMPTY_PATH AT_SYMLINK_NOFOLLOW)))
	(else (lstat object))))

(define new-stat
  (case-lambda
    ((object) (new-stat object #t))
    ((object exception-on-error?)
     (display object)
     (if (path-at? object)
	 ;; XXX respect exception-on-error?
	 (fstatat (path-at-directory object) (path-at-filename object) 0)
	 ;; already supports port objects
	 (stat object exception-on-error?)))))

(define new-mkdir
  (case-lambda
    ((object) (new-mkdir object #o777))
    ((object mode)
     (if (path-at? object)
	 (mkdirat (path-at-directory object) (path-at-filename object) mode)
	 (mkdir object mode)))))

;; S_* constants copied from pfinet/linux-src/include/linux/stat.h
;; from the hurd-headers package.
(define S_IFMT   #o170000)
(define S_IFSOCK #o140000)
(define S_IFLNK  #o120000)
(define S_IFREG  #o100000)
(define S_IFBLK  #o060000)
(define S_IFDIR  #o040000)
(define S_IFCHR  #o020000)
(define S_IFIFO  #o010000)

(define (->mode type perms)
  (logior (case type
	    ((regular) S_IFREG)
	    ((char-special) S_IFCHR)
	    ((block-special) S_IFBLK)
	    ((fifo) S_IFIFO)
	    ((socket) S_IFSOCK))
	  perms))

(define-syntax-rule (switch obj
			    (#:else exp exp* ...)
			    (key exp^ exp^* ...) ...)
  (let ((o obj))
    (cond ((eqv? o key) exp^ exp^* ...)
	  ...
	  (#t exp exp* ...))))

(define (mode->type mode)
  (switch (logand mode S_IFMT)
	  (#:else 'unknown)
	  (S_IFSOCK 'socket)
	  (S_IFREG 'regular)
	  (S_IFLNK 'symlink)
	  (S_IFIFO 'fifo)
	  (S_IFDIR 'directory)
	  (S_IFCHR 'char-special)
	  (S_IFBLK 'block-special)))

(define (mode->perms mode)
  (logand mode #o7777))

(define (new-mknod object type perms dev)
  (if (path-at? object)
      (mknodat (path-at-directory object) (path-at-filename object)
	       (->mode type perms) dev)
      (mknod object type perms dev)))