(in-package #:safer-lisp)

(defvar *safer-pathname-root* nil
  "A pathname which should be considered the root pathname for all safer-pathnames.")
(defvar *safer-pathname-validator* nil
  "A callback which takes a pathname and returns a generalized boolean stating
whether the pathname should be considered valid.")

(define-condition safer-pathname-error (safer-lisp-error) ())

(defun %safe-path-char-p (c)
  (find c "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890.-/" :test #'char-equal))

(defun |#p-reader| (stream subchar arg)
  "A pathname reader.  Replaces the implementation's pathname reader with one that
has uniform syntax: directories separated by #\/, no '..' or '.' dirs."
  (declare (ignore subchar arg))
  (if (char= #\" (peek-char nil stream))
      (let* ((pathstring (read stream t nil t))
             (pathseq (split-sequence #\/ pathstring :remove-empty-subseqs t))
             (fullname (car (last pathseq)))
             (dot (position #\. fullname :from-end t :test #'char=))
             (name (subseq fullname 0 dot))
             (type (subseq fullname (1+ dot))))
        (cond
          ((notevery #'%safe-path-char-p pathstring)
           (error 'safer-pathname-error
                  :format-control "bad char in path ~a"
                  :format-arguments (list pathstring)))
          ((some (lambda (s) (member s '(".." ".") :test #'string=))
                 pathseq)
           (error 'safer-pathname-error
                  :format-control "bad dir in path ~a"
                  :format-arguments (list pathstring)))
          (t
           (make-safer-pathname
            :directory `(:relative ,@(butlast pathseq))
            :name name
            :type type))))
      (error 'safer-pathname-error
             :format-control "syntax error")))

(eval-when (:load-toplevel)
  (set-dispatch-macro-character #\# #\p #'|#p-reader| *safer-readtable*))

(defun make-safer-pathname (&key directory name type
                            (defaults *safer-pathname-root*)
                            (valid-pathname-callback *safer-pathname-validator*))
  "Like make-pathname, but takes a few less arguments to restrict the locations
of files we can refer to, and also takes an optional valid-pathname-callback,
which if non-nil is a function of the form (pathname) => boolean, which returns
nil if the pathname is okay, and non-nil otherwise."
  (let ((p (merge-pathnames (make-pathname :directory directory :name name :type type)
                            defaults)))
    (when valid-pathname-callback
      (unless (funcall valid-pathname-callback p)
        (error 'safer-pathname-error
               :format-control "Non-safe pathname ~a"
               :format-arguments (list p))))
    p))