guile-examples/file-system/path-handling.scm

(define-module (path-handling)
  #:export (path-split
            path-join
            absolute-path?
            absolute-path
            subpath?
            file-extension
            upwards-navigating-path?))


(use-modules
 (srfi srfi-1))

;;;
;;; HELPERS
;;;


;;; LOGGING


(define displayln
  (lambda* (#:key (output-port (current-output-port)) (verbose #t) . msgs)
    (when verbose
      (display (string-append
                (string-join
                 (map (lambda (msg) (simple-format #f "~a" msg)) msgs)
                 " ") "\n")
               output-port))))


;; alias for displayln
(define debug displayln)


;;; STRINGS


(use-modules
 (ice-9 exceptions))


(define char->string
  (λ (c)
    (list->string
     (list c))))


(define string->char
  (λ (str)
    "Convert a string, which has only one single character
into a character. This is useful, because some functions
expect a characters as input instead of a string."
    (cond
     [(= (string-length str) 1)
      (car (string->list str))]
     [else
      (raise-exception
       (make-exception
        (make-non-continuable-error)
        (make-exception-with-message "trying to convert string of more than 1 character to char")
        (make-exception-with-irritants (list str))
        (make-exception-with-origin 'string->char)))])))


#;(define has-prefix?
  (λ (str prefix)
    (= (string-prefix-length str prefix)
       (string-length prefix))))


;;; LISTS


(define list-prefix?
  (λ (lst lst-prefix)
    (cond
     [(null? lst-prefix) #t]
     [(null? lst) #f]
     [else
      (cond
       [(equal? (car lst) (car lst-prefix))
        (list-prefix? (cdr lst) (cdr lst-prefix))]
       [else #f])])))


;;;
;;; PATH FUNCTIONS
;;;


(define absolute-path?
  (λ (path)
    "Check, whether the given path is an absolute path."
    ;; Guile already offers a function for this, but it is a
    ;; little bit strangely named. We only give it an alias.
    (absolute-file-name? path)))


(define path-join
  (λ (path1 . other-path-parts)
    "Join paths using the system preferred separator."
    (debug "joining path parts:" (cons path1 other-path-parts))
    (fold
     (λ (p2 p1)
       (cond
        [(null? p2) p1]
        [(absolute-path? p2) p2]
        [else
         (let ([dir-sep (car (string->list file-name-separator-string))])
           (string-append
            ;; Remove any trailing separators to make sure
            ;; there is only one separator, when the paths
            ;; are concattenated.
            (string-trim-right p1 (λ (char) (char=? char dir-sep)))
            ;; Concat the paths with the separator in the
            ;; middle.
            (char->string dir-sep)
            ;; We already know p2 is not an absolute path.
            p2))]))
     ""
     (cons path1 other-path-parts))))


(define path-split
  (λ (path)
    "Split a path by the preferred separator of the system."
    (string-split path (string->char file-name-separator-string))))


(define absolute-path
  (lambda* (path
            #:key
            (working-directory
             (dirname (or (current-filename)
                          (canonicalize-path ".")))))
    (cond
     [(absolute-path? path) path]
     [else
      ;; In case the path is not absolute already, we look
      ;; for it in the current directory.
      (let next-parent ([path-parts
                         (path-split
                          (path-join working-directory path))])
        (debug "current path-parts:" path-parts)
        (cond
         ;; WARNING: This part is not OS independent. An
         ;; absolute path does not have to start with the
         ;; separator string in all OS.
         [(null? path-parts) file-name-separator-string]
         [else
          (let ([path-str (apply path-join path-parts)])
            (debug "current path-str:" path-str)
            (with-exception-handler
                (λ (exception)
                  (debug "an exception was raised:" exception)
                  (cond
                   [(and (eq? (exception-kind exception)
                              'system-error)
                         (string=? (car (exception-irritants exception))
                                   "No such file or directory"))
                    ;; Try to check if the path to the
                    ;; parent directory exists and is an
                    ;; absolute path instead.
                    (debug "the exception is about the path not existing")
                    (apply path-join
                           (list (next-parent (drop-right path-parts 1))
                                 (last path-parts)))]
                   [else
                    (debug "unexpected exception:" exception)]))
              (λ ()
                (debug "trying to canonicalize-path" path-str)
                (canonicalize-path path-str))
              #:unwind? #t))]))])))


(define file-extension
  (λ (path)
    (cond
     ;; An empty string is given, there can be no file
     ;; extension.
     [(string-null? path) #f]
     [else
      (let ([path-last-part (last (path-split path))]
            [file-extension-separator #\.])
        (let ([last-part-split (string-split path-last-part file-extension-separator)])
          (cond
           ;; If the split did not produce more than one
           ;; part, then the split character was not found
           ;; and so the path does not have a file
           ;; extension.
           [(= (length last-part-split) 1) #f]
           [else
            (let ([perhaps-file-extension (last last-part-split)])
              ;; A file name could end with a "." and that
              ;; would produce an empty string as file
              ;; extension. This procedure does not consider
              ;; the empty string to be a file extension.
              (if (string-null? perhaps-file-extension)
                  #f
                  perhaps-file-extension))])))])))


(define subpath?
  (λ (path parent-path)
    "Check, whether a path is a sub path of a given parent
path."
    (cond
     ;; We want to avoid complicated paths for now and
     ;; simply claim, that upwards navigating paths are not
     ;; in any parent path for security reasons.
     [(upwards-navigating-path? path) #f]
     [else
      (let ([path-parts (path-split path)]
            [parent-path-parts (path-split parent-path)])
        (list-prefix? (path-split path)
                      (path-split parent-path)))])))


(define upwards-navigating-path?
  (λ (path)
    "Check, whether the given path contains anything, which
could be used to navigate upwards in the file system
tree. This is useful, when trying to make sure, that a path
does not point to resources, which the context shall have no
access to."
    (cond
     ;; contains sub shell
     [(string-contains path "`") #t]
     ;; contains upwards navigation
     [(string-contains path "/../") #t]
     ;; ends with 2 or more dots
     [(>= (string-suffix-length path "..") 2) #t]
     ;; contains tilde
     [(string-contains path "~") #t]
     ;; contains variables
     [(string-contains path "$") #t]
     ;; otherwise seems to be safe
     [else #f])))