cl-deck-builder2/src/toolkit/paths.lisp

#|

src/toolkit/paths.lisp

Utilities For Working With Directories, Files, Paths, etc.

|#

(in-package #:cl-deck-builder2.toolkit.paths)

;;;; Code for munging paths and finding files at paths and renaming
;;;; files and that sort of thing.

(defvar +ygoprodeck-images-root+
  (merge-pathnames #P"ygoprodeck/" *public-directory*)
  "The path to where the web server can display YGOProDeck images.")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun probe-file-list (seq defaults)
  "PROBE-FILE-LIST wille apply PROBE-FILE to every file in SEQ.

It appears we also do some MERGE-PATHNAMES trickery."
  (mapcar (lambda (filename)
            (probe-file
             (merge-pathnames filename defaults)))
          seq))

(defun relative-file-list (seq &key (type "jpg"))
  "RELATIVE-FILE-LIST takes a LIST of files and transforms them into data that can be presented on the web interface, e.g. for A HREF URLs.

RELATIVE is in the title because we use PATHNAME-NAME to strip out any directory components on elements of SEQ.

ARGUMENTS:
SEQ      A LIST of files.
DEFAULTS This is passed as the defaults argument to MERGE-PATHNAMES.

SEE STATIC-RELATIVE-FILE-LIST
SEE YGO-RELATIVE-FILE-LIST"
  (mapcar (lambda (file)
            (make-pathname :name file :type type))
          (mapcar  #'pathname-name seq)))

(defun static-probe-file-list (seq)
  "STATIC-PROBE-FILE-LIST takes a LIST of Yu-Gi-Oh! passcodes and transforms them into data that can be presented on the web interface,e.g. for A HREF URLs.

STATIC-PROBE-FILE-LIST takes a LIST of files and transforms them into data that can be presented on the web interface, e.g. for A HREF URLs. We use *PUBLIC-DIRECTORY* as the root directory for the output.

ARGUMENTS:
SEQ      A LIST of files.

SEE RELATIVE-FILE-LIST"
  (probe-file-list seq
   (relative-pathname *public-directory*)))

(defun ygo-probe-file-list (seq)
  "YGO-RELATIVE-FILE-LIST takes a LIST of Yu-Gi-Oh! passcodes and transforms them into data that can be presented on the web interface,e.g. for A HREF URLs.

ARGUMENTS:
SEQ      A LIST of files.

SEE RELATIVE-FILE-LIST"
  (probe-file-list
   (relative-file-list (mapcar #'princ-to-string seq) :type "jpg")
   (relative-pathname +ygoprodeck-images-root+)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun make-static-filename-kind (pathname-name maybe-list &key (type "jpg"))
  "We use UIOP:ENSURE-LIST so this may be called with one LIST argument.

TODO That seems kinda hacky to me."
  (merge-pathnames
   (make-pathname :name (format nil "~A-~{~A~^-~}"
                                pathname-name
                                (uiop:ensure-list maybe-list))
                  :type type)
   *public-directory*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Get the files from the file system .. so sloppy ...
(defun image-files-list (name)
  (mapcar
   (lambda (kind)
     (make-static-filename-kind name kind))
   '("MAIN" "EXTRA" "SIDE" "MAIN-EXTRA" "MAIN-SIDE" "FINAL")))

(defun probe-image-files-list (name &optional (strip t))
  (let* ((pathname *public-directory*)
         (len (length (namestring pathname))))
    (remove
     NIL
     (mapcar
      (lambda (path)
        (if (probe-file path)
            (if strip
                (subseq (namestring path) len)
                path)))
      (image-files-list name)))))

;; TODO UIOP:ENOUGH-PATHNAME

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This had to be here, in WEB package probably, because YDK depends
;; on TOOLKIT so it can't go in TOOLKIT because it depends on YDK: it
;; uses YDK-NAME-OF. Perhaps I could pass just a name into this and
;; make it deck agnostic.
;;
;; Okay I've done exactly that.
(defun ydk-rename-files (old-name new-name)
  "Rename the files from DECK if there are any files according to PROBE-IMAGE-FILES-LIST.

If there are images, NEW-NAME will replace the PATHNAME-NAME of the old images."
  (let* ((old-files (probe-image-files-list old-name nil))
         (new-files
           (mapcar (lambda (path)
                     (merge-pathnames
                      (make-pathname :name path :type "jpg") *public-directory*))
                   (mapcar (lambda (old-path)
                             (cl-ppcre:regex-replace-all old-name (pathname-name old-path) new-name))
                           old-files))))
    ;; (format t "<pre>~a</pre>" (mapcar #'list old-files new-files))))
    (mapcar (lambda (pair)
              (when (probe-file (car pair))
                (rename-file (car pair) (cadr pair))))
            (mapcar #'list old-files new-files))))

(defun relative-pathname (name)
  (asdf:system-relative-pathname :cl-deck-builder2 name))

(defun public-pathname (name)
  (merge-pathnames name *public-directory*))

(defun static-pathname (name)
  (merge-pathnames name *static-directory*))

(defun ygo-pathname (name)
  (merge-pathnames name +ygoprodeck-images-root+))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Was originally from files.lisp

(defun digest-file-string (digest-spec pathspec &rest args)
  (format nil "~{~x~}"
          (coerce (apply #'ironclad:digest-file digest-spec pathspec args)
                  'list)))

;; (random-filename (pathname-type pathspec)) => uuid.type
(defun random-pathname-name (&key type)
  (let ((uuid (uuid:print-bytes nil (uuid:make-v4-uuid))))
    (format nil "~a~@[.~a~]" uuid type)))