guile-fslib/fslib.scm

;;; NOTE: This code makes use of an invented term "fsing",
;;; which is a combination of "fs" and "thing", in lack of a
;;; better name for something that a string like "/a/b/c"
;;; describes. The word "path" is in some contexts
;;; understood to be a string containing multiple
;;; directories, usually delimited by a separator like ":",
;;; as for example in "/a/bin:/b/c/lib/bin:/bla". Using the
;;; word "path" can be confusing for people from those
;;; contexts. Using the word "file" instead can be confusing
;;; for other people, who expect things to be really a file
;;; and not a directory, when seeing the word "file". So
;;; neither "file" nor "path" are safe to use and a new term
;;; is come up with.

;;; An "fsing" is a string describing, where to find a
;;; "thing" inside the file system. Examples:

;;; "/a/b/c"
;;; "../a/b/c"
;;; "./a/b/c"
;;; "/a/../b/c"
;;; "/a/./b/c"

;;; "/a/b/c.txt"
;;; "../a/b/c.txt"
;;; "./a/b/c.txt"
;;; "/a/../b/c.txt"
;;; "/a/./b/c.txt"

;;; "a/b/c"
;;; "a/../b/c"
;;; "a/./b/c"
;;; "a/b/c.txt"
;;; "a/../b/c.txt"
;;; "a/./b/c.txt"


(library (fslib (0 1 0))
  (export absolute-fsing
          absolute-fsing?
          fsing-join
          fsing-split
          file-extension
          file-name
          dir-name
          sub-fsing?
          complex-fsing?
          get-current-directory
          parent-fsing)
  (import
    (except (rnrs base) let-values)
    (only (guile)
          ;; lambda forms
          lambda* λ
          ;; file system stuff
          dirname
          basename
          file-name-separator-string
          canonicalize-path
          absolute-file-name?
          current-filename
          current-output-port
          ;; string stuff
          string-null?
          string-trim-right
          string-split
          string-join
          string-contains
          string-suffix-length
          ;; exception stuff
          false-if-exception
          ;; debugging
          pk
          simple-format)
    ;; Guile modules
    ;; alist->hash-table
    ;; (prefix (ice-9 hash-table) ice9-hash-table:)
    ;; Guile exception handling
    (ice-9 exceptions)
    ;; (ice-9 session)
    ;; for bytevector operations
    (ice-9 binary-ports)
    ;; SRFIs
    ;; list functions
    ;; (prefix (srfi srfi-1) srfi-1:)
    ;; hash tables
    ;; (prefix (srfi srfi-69) srfi-69:)
    ;; receive form
    ;; (prefix (srfi srfi-8) srfi-8:)
    ;; let-values
    ;; (prefix (srfi srfi-11) srfi-11:)
    ;; list utils
    (prefix (srfi srfi-1) srfi-1:)
    ;; web server, concurrent
    (string-utils)
    (list-utils)
    (file-system)
    (prefix (logging) log:)))


(define fsing-sep file-name-separator-string)


(define fsing-join
  (λ (fsing1 . other-fsing-parts)
    "Join fsings using the system preferred separator."
    (let ([all-parts (cons fsing1 other-fsing-parts)])
      (let ([dir-sep (car (string->list fsing-sep))])
        (string-join
         ;; Remove one suffix separator. One will be added
         ;; by joining again. This prevents joining from
         ;; changing the parts.
         (map-to-all-except-last
          (λ (part)
            ;; (log:debug "removing" dir-sep "from suffix of" part)
            (remove-suffix part (char->string dir-sep)))
          ;; TODO: FUTURE: Perhaps use a vector instead, to
          ;; avoid having to reverse a list, which is O(n)
          ;; for the number of parts. Although perhaps not,
          ;; because usually not so many parts are joined
          ;; and the list could even be faster for small n.
          (reverse
           (let next ([accumulated-parts '()]
                      [remaining-parts
                       (srfi-1:filter (λ (part)
                                        (not (string-null? part)))
                                      all-parts)])
             (cond
              [(null? remaining-parts) accumulated-parts]
              ;; If a later fsing is an absolute fsing, then
              ;; it is used as the new accumulated
              ;; value. Basically a later absolute fsing
              ;; overrides the already accumulated fsing,
              ;; because it cannot be joined in a useful
              ;; way.
              [else
               (let ([current-part (car remaining-parts)])
                 (cond
                  [(absolute-fsing? current-part)
                   ;; Recur with only the current element as
                   ;; accumulate parts.
                   (next (list current-part)
                         (cdr remaining-parts))]
                  ;; We know, that the current-elem is not
                  ;; an absolute fsing and so it can be
                  ;; usefully joined with the already
                  ;; accumulated fsing.
                  [else
                   ;; Accumulate in reversed order, so that
                   ;; we do not need to use append.
                   (next (cons current-part accumulated-parts)
                         (cdr remaining-parts))]))]))))
         ;; Join with the separator as string.
         (char->string dir-sep))))))


(define fsing-split
  (λ (fsing)
    "Split a fsing by the preferred separator of the
system."
    (string-split fsing (string->char fsing-sep))))


(define fsing-empty?
  (λ (str)
    (string-null? str)))


(define absolute-fsing
  (lambda* (fsing #:key
                  (working-directory (get-current-directory))
                  (canonicalize #f))
    "Return the absolute fsing of a given absolute or
non-absolute fsing.

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 fsings for non-absolute fsings do
not necessarily depend on where exactly this module is
located in the file system."
    (cond
     ;; An empty fsing means current directory.
     [(fsing-empty? fsing) (absolute-fsing working-directory)]
     ;; If the fsing is already an absolute fsing, simply
     ;; return that, but only if it does not need to be
     ;; canonicalized.
     [(and (absolute-fsing? fsing) (not canonicalize)) fsing]
     [else
      ;; In case the fsing is not absolute already, we look
      ;; for it in the current directory.
      (let next ([fsing-parts
                  ;; Splitting the fsing to work with its
                  ;; parts means, that the list of parts
                  ;; will contain the empty string, if the
                  ;; fsing starts with the separator, which
                  ;; usually implies an absolute fsing.
                  (fsing-split (fsing-join working-directory fsing))]
                 [accumulated-parts '()])
        (cond
         ;; WARNING: This part is not OS independent. An
         ;; absolute fsing does not have to start with the
         ;; separator string in all OS.

         ;; If there are no more parts, return the
         ;; accumulated parts.
         [(null? fsing-parts)
          ;; An empty first string in accumulated-parts
          ;; implies an absolute fsing. However, joining
          ;; would not translate it into an absolute fsing,
          ;; so we need to change that first string into a
          ;; separator.
          (apply fsing-join
                 (let ([rev-acc-parts (reverse accumulated-parts)])
                   (cond
                    [(string-null? (car rev-acc-parts))
                     (cons fsing-sep (cdr rev-acc-parts))]
                    [else
                     rev-acc-parts])))]
         ;; if canonicalize, then check for ".." and for "."
         ;; and act accordingly
         [canonicalize
          (cond
           ;; ignore "." parts
           [(string=? (car fsing-parts) ".")
            (next (cdr fsing-parts) accumulated-parts)]
           ;; ".." reduces accumulated-parts by 1 part
           [(string=? (car fsing-parts) "..")
            (next (cdr fsing-parts)
                  (cdr accumulated-parts))]
           [else
            (next (cdr fsing-parts)
                  (cons (car fsing-parts)
                        accumulated-parts))])]
         ;; progress without checking for ".." and "."
         [else
          (next (cdr fsing-parts)
                (cons (car fsing-parts)
                      accumulated-parts))]))])))


(define absolute-fsing?
  (λ (fsing)
    "Check, whether the given fsing is an absolute fsing."
    ;; 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? fsing)))


(define file-extension
  (λ (fsing)
    "Get the file extension of the given fsing or #f if
there is no file extension."
    (cond
     ;; An empty string is given, there can be no file
     ;; extension.
     [(string-null? fsing) #f]
     [else
      (let ([fsing-last-part (basename fsing)]
            [file-extension-separator #\.])
        (let ([last-part-split (string-split fsing-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 fsing does not have a file
           ;; extension.
           [(= (length last-part-split) 1) #f]
           [else
            (let ([perhaps-file-extension (srfi-1: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 file-name
  (lambda* (fsing #:key (file-extension-separator #\.))
    "Return the name part of a filename (the filename without
the file extension)."
    (let ([base (basename fsing)])
      (let ([parts (string-split base file-extension-separator)])
        (cond
         [(null? parts) #f]
         [(= (length parts) 1) base]
         [(and (= (length parts) 2)
               (string-null? (srfi-1:first parts)))
          #f]
         [else
          (string-join (srfi-1:drop-right parts 1)
                       (char->string file-extension-separator))])))))


(define sub-fsing?
  (λ (fsing parent-fsing)
    "Check, whether a fsing is a sub fsing of a given parent
fsing."
    (cond
     ;; We want to avoid complicated fsings for now and
     ;; simply claim, that complex fsings are not in any
     ;; parent fsing for security reasons.
     [(complex-fsing? fsing) #f]
     [else
      (let ([canon-abs-fsing (absolute-fsing fsing #:canonicalize #t)]
            [canon-abs-parent-fsing (absolute-fsing parent-fsing #:canonicalize #t)])

        (let ([fsing-parts (fsing-split canon-abs-fsing)]
              [parent-fsing-parts
               (fsing-split (remove-multiple-suffix canon-abs-parent-fsing fsing-sep))])
          (list-prefix? fsing-parts parent-fsing-parts)))])))


(define complex-fsing?
  (λ (fsing)
    "Check, whether the given fsing 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 fsing does
not point to resources, which the context shall have no
access to."
    (cond
     ;; contains sub shell
     [(string-contains fsing "`") #t]
     ;; contains upwards navigation
     ;; [(string-contains fsing "/../") #t]
     ;; contains 2 dots
     ;; [(string-contains fsing "..") #t]
     ;; contains tilde
     [(string-contains fsing "~") #t]
     ;; contains variables
     [(string-contains fsing "$") #t]
     ;; otherwise seems to be safe
     [else #f])))


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


(define parent-fsing
  (λ (fsing)
    ;; simply using already in GNU Guile defined procedure dirname
    (dirname fsing)))