(import chicken scheme)
(use matchable files posix data-structures)

(define (create-file name)
  (with-output-to-file name (constantly #t)))

(define (create-directory-tree dir spec)
  (define (filename? s) (or (string? s) (symbol? s)))
  (match spec
    [(? filename? file)
     (create-file (make-pathname dir (->string file)))]
    [((? filename? path) . options)
     (let ([path (make-pathname dir (->string path))])
       (let loop ([args options]
                  [mode 0]
                  [owner #f]
                  [group #f]
                  [symlink #f]
                  [thunk #f])
         (match args
           [('#:mode mode . rest)
            (loop rest mode owner group symlink thunk)]
           [('#:owner owner . rest)
            (loop rest mode owner group symlink thunk)]
           [('#:group group . rest)
            (loop rest mode owner group symlink thunk)]
           [('#:symlink sympath . rest)
            (loop rest mode owner group sympath thunk)]
           [((? procedure? proc))
            (loop '() mode owner group symlink
                  (lambda ()
                    (call-with-output-file path proc)))]
           [((? string? str))
            (loop '() mode owner group symlink
                  (lambda ()
                    (with-output-to-file path (lambda () (display str)))))]
           ['()
            (let ([thunk (or thunk (lambda ()
                                     (with-output-to-file path (constantly #t))))])
              (if symlink
                  (create-symbolic-link symlink path)
                  (begin
                    (thunk)
                    (when (not (zero? mode))
                      (change-file-mode path mode))
                    (when (or owner group)
                      (let ([owner (or owner (current-user-id))]
                            [group (or group (current-group-id))])
                        (change-file-owner path owner group))))))]
           [(subspecs)
            (create-directory path)
            (when (not (zero? mode))
              (change-file-mode path mode))
            (when (or owner group)
              (let ([owner (or owner (current-user-id))]
                    [group (or group (current-group-id))])
                (change-file-owner path owner group)))
            (for-each (cut create-directory-tree path <>) subspecs)]
           [other (error "Don't know what to do with" other)])))]
    [other (error "Don't know what to do with" other)]))

(define (check-directory-tree dir spec)
  (define (filename? s) (or (string? s) (symbol? s)))
  (match spec
    [(? filename? s) (regular-file? (make-pathname dir (->string s)))]
    [((? filename? path) . options)
     (let ([path (make-pathname dir (->string path))])
       (let loop ([args options])
         (match args
           [('#:mode perm . rest)
            (and (= perm (bitwise-and (file-permissions path) perm))
                 (loop rest))]
           [('#:symlink link . rest)
            (and (symbolic-link? path)
                 (string=? link (read-symbolic-link path))
                 (loop rest))]
           [('#:owner owner . rest)
            (and (= (file-owner path) owner)
                 (loop rest))]
           [('#:group group . rest)
            (and (= group (vector-ref (file-stat path) 4))
                 (loop rest))]
           ['() #t]
           ['(()) (directory-exists? path)]
           [((subspec . subspecs))
            (and (directory-exists? path)
                 (check-directory-tree path subspec)
                 (check-directory-tree path subspecs))]
           [other (error "Don't know what to do with" other)])))]
    [(f . r) (and (check-directory-tree dir f) (check-directory-tree dir r))]
    ['() #t]
    [other (error "Don't know what to do with" other)]))