guile-examples/web-development/example-03-serve-static-assets/path-handling.scm

(define-module (path-handling)
  #:export (absolute-path
            absolute-path?
            path-join
            path-split
            file-extension
            subpath?
            complex-path?
            get-current-directory))


(use-modules
 ;; for fold, last
 (srfi srfi-1)
 (ice-9 exceptions)
 ;; custom modules
 (string-utils)
 (list-utils)
 ((logging) #:prefix log:)
 (file-system))


(define path-join
  (λ (path1 . other-path-parts)
    "Join paths using the system preferred separator."
    (let ([dir-sep (car (string->list file-name-separator-string))])
      (fold
       (λ (current-elem accumulated)
         (cond
          ;; If a later path is an absolute path, then it is
          ;; used as the new accumulated value. Basically a
          ;; later absolute path overrides the already
          ;; accumulated path, because it cannot be joined in
          ;; a useful way.
          [(absolute-path? current-elem) current-elem]
          ;; We know, that the current-elem is not an absolute
          ;; path and so it can be usefully joined with the
          ;; already accumulated path.
          [else
           ;; If the first element is the empty string, then
           ;; we should make an absolute path. We know the
           ;; first element by looking at what is already
           ;; accumulated. If the accumulated path is also
           ;; still empty, then we are at the beginning of
           ;; path parts.
           (cond
            ;; Are we at the beginning?
            [(string-null? accumulated)
             (cond
              ;; Is the first element the empty string? Then
              ;; make an absolute path.
              ;; NOTE: WARNING: This is not OS independent!
              ;; Absolute paths do not have to start with
              ;; the directory separator on all OS.
              [(string-null? current-elem) (char->string dir-sep)]
              ;; Otherwise use the first element as
              ;; accumulated path and go on with the rest.
              [else current-elem])]
            ;; If we are not at the beginning, then the path
            ;; cannot become absolute any longer.
            [else
             (string-append
              ;; Remove any trailing separators to make sure
              ;; there is only one separator, when the paths
              ;; are concattenated.
              (string-trim-right accumulated
                                 (λ (char)
                                   (char=? char dir-sep)))
              ;; Concat the paths with the separator in the
              ;; middle.
              (char->string dir-sep)
              ;; We already know current-elem is not an
              ;; absolute path.
              current-elem)])]))
       ""
       (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
            ;; We give the working directory as a keyword
            ;; argument, so that this procedure does not
            ;; need to make the decision on its own and the
            ;; resulting absolute paths for non-absolute
            ;; paths do not necessarily depend on where
            ;; exactly this module is located in the file
            ;; system.
            #:key
            (working-directory (get-current-directory)))
    "Return the absolute path of a given absolute or non-absolute path."
    (cond
     ;; If the path is already an absolute path, simply
     ;; return that.
     [(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))])
        (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)]
                 [canon-abs-path (false-if-exception (canonicalize-path path-str))])
            (cond
             [(not canon-abs-path)
              (apply path-join
                     (list (next-parent (drop-right path-parts 1))
                           (last path-parts)))]
             [else
              canon-abs-path]))]))])))


(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, as it can be used for
    ;; files and directories, not only for files. We only
    ;; give it an alias.
    (absolute-file-name? path)))


(define file-extension
  (λ (path)
    "Get the file extension of the given path or #f if there
is no file extension."
    (cond
     ;; An empty string is given, there can be no file
     ;; extension.
     [(string-null? path) #f]
     [else
      (let ([path-last-part (basename 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.
     [(complex-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 complex-path?
  (λ (path)
    "Check, whether the given path contains anything, which
could be used to navigate upwards in the file system tree or
is in any way complex.

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 (a file could be named 3 or more dots)
     [(>= (string-suffix-length path "...") 3) #t]
     ;; contains tilde
     [(string-contains path "~") #t]
     ;; contains variables
     [(string-contains path "$") #t]
     ;; otherwise seems to be safe
     [else #f])))


(define get-current-directory
  (λ ()
    (dirname
     (or (current-filename)
         (canonicalize-path ".")))))