path: root/stdlib/copy-file.tl

;; Copyright 2018-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
;; 1. Redistributions of source code must retain the above copyright notice,
;;    this list of conditions and the following disclaimer.
;;
;; 2. 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.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 COPYRIGHT HOLDER OR CONTRIBUTORS 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.

(eval-only
  (defsymacro copy-size 65536))

(defstruct copy-path-opts ()
  perms times owner symlinks (euid (geteuid)))

(defstruct copy-path-stack-node ()
  path stat new-p)

(defun make-copy-path-opts (opt-list)
  (if opt-list
    (let (opts)
      (each ((opt opt-list))
        (if (structp opt)
          (set opts opt)
          (progn
            (unless opts
              (set opts (new copy-path-opts)))
            (caseql opt
              (:perms (set opts.perms t))
              (:times (set opts.times t))
              (:owner (set opts.owner t))
              (:symlinks (set opts.symlinks t))
              (:all (set opts.perms t
                         opts.times t
                         opts.owner t
                         opts.symlinks t))
              (t (error "~s: unrecognized option ~s" 'copy-path opt))))))
      opts)
    (load-time (new copy-path-opts))))

(defun copy-file (from-path to-path : preserve-perms preserve-times)
  (with-resources ((buf (make-buf copy-size)
                        (buf-set-length buf 0) (buf-trim buf))
                   (ist (open-file from-path "b") (close-stream ist))
                   (ista (fstat ist))
                   (ost (if (path-dir-p ista)
                          (throwf 'path-permission `~s: ~a is a directory`
                                  'copy-file from-path)
                          (open-file to-path "wb"))
                        (close-stream ost)))
    (while (eql (len buf) copy-size)
      (fill-buf-adjust buf 0 ist)
      (put-buf buf 0 ost))
    (when preserve-perms
      (chmod ost ista.mode))
    (when preserve-times
      (flush-stream ost)
      (utimes ost
              ista.atime (or ista.atime-nsec 0)
              ista.mtime (or ista.mtime-nsec 0)))
    nil))

(defun copy-files (paths dest-dir : preserve-perms preserve-times)
  (each ((path paths))
    (while t
      (catch**
        (return (copy-file path (path-cat dest-dir (base-name path))
                           preserve-perms preserve-times))
        (skip `skip copying @path` (exc . args)
          (ignore args exc)
          (return))
        (retry `retry copying @path` (exc . args)
          (ignore args exc))))))

(defun cat-files (to-path . from-paths)
  (let ((buf (make-buf copy-size)))
    (with-stream (ost (open-file to-path "wb"))
      (each ((from-path from-paths))
        (with-stream (ist (open-file from-path "b"))
          (while (eql (len buf) copy-size)
            (fill-buf-adjust buf 0 ist)
            (put-buf buf 0 ost)))
        (buf-set-length buf copy-size)))
    (buf-set-length buf 0)
    (buf-trim buf)
    nil))

(defun do-tweak-obj (to-path st opts link-p)
  (when (and opts.perms (not link-p))
    (chmod to-path st.mode))
  (when opts.times
    (lutimes to-path
             st.atime (or st.atime-nsec 0)
             st.mtime (or st.mtime-nsec 0)))
  (when (and opts.owner
             (or (zerop opts.euid)
                 (and (path-mine-p st)
                      (path-my-group-p st))))
    (lchown to-path st.uid st.gid)))

(defun do-copy-obj (from-path to-path st opts)
  (let ((type (logand st.mode s-ifmt))
        (initial-perms (if opts.perms #o700 #o777))
        (tweak t))
    (caseql* type
      (s-ifreg
        (copy-file from-path to-path opts.perms opts.times))
      (s-ifsock
        (mknod to-path (logior type initial-perms)))
      (s-ififo
        (mkfifo to-path initial-perms))
      (s-iflnk
        (if opts.symlinks
          (symlink (readlink from-path) to-path)
          (progn
            (do-copy-obj from-path to-path (stat from-path) opts)
            (set tweak nil))))
      ((s-ifblk s-ifchr)
       (mknod to-path (logior type initial-perms) st.rdev))
      (s-ifdir
        (ensure-dir to-path)))
    (when tweak
      (do-tweak-obj to-path st opts (eq type s-iflnk)))))

(defun copy-path-rec (from-dir to-dir . opt-list)
  (let* ((opts (make-copy-path-opts opt-list))
         (dir-stack nil))
    (unwind-protect
      (ftw from-dir
           (lambda (path type stat . rest)
             (ignore rest)
             (while t
               (catch**
                 (let* ((rel-path (rel-path from-dir path))
                        (tgt-path (path-cat to-dir rel-path)))
                   (caseql* type
                     ((ftw-dnr ftw-ns) (error "~s: unable to access ~s"
                                              'copy-path path))
                     (ftw-d (let ((new-p (ensure-dir tgt-path)))
                              (whilet ((top (car dir-stack))
                                       ((and top
                                             (not (starts-with tgt-path
                                                               top.path)))))
                                (do-tweak-obj top.path top.stat opts nil)
                                (pop dir-stack))
                              (push (new copy-path-stack-node
                                         path tgt-path
                                         stat stat
                                         new-p new-p)
                                    dir-stack)))
                     (t (iflet ((cur (car dir-stack)))
                          (unless cur.new-p
                            (remove-path tgt-path)))
                        (do-copy-obj path tgt-path stat opts)))
                   (return))
                 (skip `skip copying @path` (exc . args)
                   (ignore exc args)
                   (return))
                 (retry `retry copying @path` (exc . args)
                   (ignore exc args)))))
           ftw-phys)
      (whilet ((top (pop dir-stack)))
        (do-tweak-obj top.path top.stat opts nil)))))

(defun remove-path-rec (path)
  (ftw path
       (lambda (path type . rest)
         (ignore rest)
         (while t
           (catch**
             (return
               (caseql* type
                 ((ftw-dnr ftw-ns) (error "~s: unable to access ~s"
                                          'remove-rec path))
                 (ftw-dp (rmdir path))
                 (t (remove-path path))))
             (skip `skip removing @path` (exc . args)
               (ignore exc args)
               (return))
             (retry `retry copying @path` (exc . args)
               (ignore exc args)))))
       (logior ftw-phys ftw-depth)))

(defun chmod-rec (path perm)
  (ftw path
       (lambda (path type . rest)
         (ignore rest)
         (while t
           (catch**
             (return
               (caseql* type
                 ((ftw-dnr ftw-ns) (error "~s: unable to access ~s"
                                          'remove-rec path))
                 (ftw-sl)
                 (t (chmod path perm))))
             (skip `skip chmod @path` (exc . args)
               (ignore exc args)
               (return))
             (retry `retry chmod @path` (exc . args)
               (ignore exc args)))))
       (logior ftw-phys)))

(defun chown-rec (path uid gid)
  (ftw path
       (lambda (path type . rest)
         (ignore rest)
         (while t
           (catch**
             (return
               (caseql* type
                 ((ftw-dnr ftw-ns) (error "~s: unable to access ~s"
                                          'remove-rec path))
                 (t (lchown path uid gid))))
             (skip `skip chown @path` (exc . args)
               (ignore exc args)
               (return))
             (retry `retry chown @path` (exc . args)
               (ignore exc args)))))
       (logior ftw-phys)))

(defun touch (path : ref-path)
  (with-stream (s (or (ignerr (open-file path "mn")) (open-file path "n")))
    (if ref-path
      (let ((rst (stat ref-path)))
        (utimes s 0 nil rst.mtime rst.mtime-nsec))
      (utimes s 0 nil 0 t))))