#lang scheme
(require
 srfi/17
 srfi/19
 scheme/foreign
 (only-in scheme/contract [-> ->/c])
 "apr.ss"
 "subr.ss")
(unsafe!)
(unsafe-apr!)
(unsafe-subr!)

(define libsvn-fs
  (ffi-lib "libsvn_fs-1"))

(define libsvn-delta
  (ffi-lib "libsvn_delta-1"))

;;; Library initialization

(define global-pool
  (make-pool #f))

(define initialize
  (get-ffi-obj
   "svn_fs_initialize" libsvn-fs
   (_fun [pool : _pool]
         -> [error : _error/null]
         -> (check-error 'initialize error))))

(initialize global-pool)

;;; Filesystem object management

(define-cpointer-type _fs _pooled-pointer)

(provide _fs _fs/null fs?)

(define fs-create
  (wrapper-with-pool (path)
    ((get-ffi-obj
      "svn_fs_create" libsvn-fs
      (_fun [fs : (_ptr o _fs/null)] [path : _path]
            [config : _pointer = #f] [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-create error)
                 fs)))
     (path->complete-path path))))

(define fs-open
  (wrapper-with-pool (path)
    ((get-ffi-obj
      "svn_fs_open" libsvn-fs
      (_fun [fs : (_ptr o _fs/null)] [path : _path]
            [config : _pointer = #f] [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-open error)
                 fs)))
     (path->complete-path path))))

(define fs-hotcopy
  (wrapper-with-pool (src dst clean?)
    ((get-ffi-obj
      "svn_fs_hotcopy" libsvn-fs
      (_fun [src : _path] [dst : _path]
            [clean? : _bool]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (check-error 'fs-hotcopy error)))
     (path->complete-path src) (path->complete-path dst) clean?)))

(define fs-delete
  (wrapper-with-pool (path)
    ((get-ffi-obj
      "svn_fs_delete_fs" libsvn-fs
      (_fun [path : _path]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (check-error 'fs-delete error)))
     (path->complete-path path))))

(provide fs-create fs-open fs-hotcopy fs-delete)

;;; Information about file system objects

(define fs-type
  (wrapper-with-pool (path)
    ((get-ffi-obj
      "svn_fs_type" libsvn-fs
      (_fun [type : (_ptr o _symbol)] [path : _path]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-type error)
                 type)))
     (path->complete-path path))))

(define fs-path
  (wrapper-with-pool (fs)
    ((get-ffi-obj
      "svn_fs_path" libsvn-fs
      (_fun [fs : _fs]
            [pool : _pool = (current-pool)]
            -> [path : _path]))
     fs)))

(define set-fs-uuid!
  (wrapper-with-pool (fs uuid)
    ((get-ffi-obj
      "svn_fs_set_uuid" libsvn-fs
      (_fun [fs : _fs]
            [uuid : _bytes]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (check-error 'set-fs-uuid! error)))
     fs uuid)))

(define fs-uuid
  (getter-with-setter
   (wrapper-with-pool (fs)
     ((get-ffi-obj
       "svn_fs_get_uuid" libsvn-fs
       (_fun [fs : _fs]
             [uuid : (_ptr o _bytes)]
             [pool : _pool = (current-pool)]
             -> [error : _error/null]
             -> (begin
                  (check-error 'fs-uuid error)
                  uuid)))
      fs))
   set-fs-uuid!))

(provide fs-type fs-path fs-uuid set-fs-uuid!)

;;; Access contexts

(define-cpointer-type _fs-access _pooled-pointer)

(provide _fs-access _fs-access/null fs-access?)

(define make-fs-access
  (wrapper-with-pool (username)
    ((get-ffi-obj
      "svn_fs_create_access" libsvn-fs
      (_fun [context : (_ptr o _fs-access/null)]
            [username : _string/utf-8]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'make-fs-access error)
                 context)))
     username)))

(define fs-access-username
  (get-ffi-obj
   "svn_fs_access_get_username" libsvn-fs
   (_fun [username : (_ptr o _string/utf-8)]
         [context : _fs-access]
         -> [error : _error/null]
         -> (begin
              (check-error 'fs-access-username error)
              username))))

(define fs-access-add-lock-token!
  (local [(define fs-access-add-lock-token*
            (get-ffi-obj
             "svn_fs_access_add_lock_token" libsvn-fs
             (_fun [context : _fs-access] [token : _pointer]
                   -> [error : _error/null]
                   -> (check-error 'fs-access-add-lock-token! error))))]
    (λ (context token)
      (parameterize ([current-pool (pointer-pool context)])
        (fs-access-add-lock-token* context (bytes-copy/pool token))))))

(define set-fs-access!
  (get-ffi-obj
   "svn_fs_set_access" libsvn-fs
   (_fun [fs : _fs] [context : _fs-access/null]
         -> [error : _error/null]
         -> (check-error 'set-fs-access! error))))

(define fs-access
  (getter-with-setter
   (local [(define fs-access*
             (get-ffi-obj
              "svn_fs_get_access" libsvn-fs
              (_fun [context : (_ptr o _fs-access/null)] [fs : _fs]
                    -> [error : _error/null]
                    -> (begin
                         (check-error 'fs-access error)
                         context))))]
     (λ (fs)
       (parameterize ([current-pool (pointer-pool fs)])
         (fs-access* fs))))
   set-fs-access!))

(provide
 make-fs-access fs-access-username fs-access-add-lock-token!
 fs-access set-fs-access!)

;;; Revisions

(define fs-youngest-rev
  (wrapper-with-pool (fs)
    ((get-ffi-obj
      "svn_fs_youngest_rev" libsvn-fs
      (_fun [rev : (_ptr o _long)]
            [fs : _fs]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-youngest-rev error)
                 rev)))
     fs)))

(define set-fs-rev-prop!
  (wrapper-with-pool (fs rev prop-name value)
    ((get-ffi-obj
      "svn_fs_change_rev_prop" libsvn-fs
      (_fun [fs : _fs] [rev : _long]
            [prop-name : _symbol] [value : _svn-string-pointer/null]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (check-error 'set-fs-rev-prop! error)))
     fs rev prop-name (bytes->svn-string value))))

(define fs-rev-prop
  (getter-with-setter
   (wrapper-with-pool (fs rev prop-name)
     ((get-ffi-obj
       "svn_fs_revision_prop" libsvn-fs
       (_fun [value : (_ptr o _svn-string-pointer/null)]
             [fs : _fs] [rev : _long]
             [prop-name : _symbol]
             [pool : _pool = (current-pool)]
             -> [error : _error/null]
             -> (begin
                  (check-error 'fs-rev-prop error)
                  (svn-string->bytes value))))
      fs rev prop-name))
   set-fs-rev-prop!))

(define fs-list-rev-props
  (wrapper-with-pool (fs rev)
    ((get-ffi-obj
      "svn_fs_revision_proplist" libsvn-fs
      (_fun [hash : (_ptr o _apr-hash/null)]
            [fs : _fs] [rev : _long]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-list-rev-props error)
                 (map (compose string->symbol bytes->string/utf-8)
                      (apr-hash->keys hash)))))
     fs rev)))

(define fs-deltify-rev
  (wrapper-with-pool (fs rev)
    ((get-ffi-obj
      "svn_fs_deltify_revision" libsvn-fs
      (_fun [fs : _fs] [rev : _long]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (check-error 'fs-deltify-rev error)))
     fs rev)))

(provide
 fs-youngest-rev fs-rev-prop set-fs-rev-prop! fs-list-rev-props fs-deltify-rev)

;;; Locks

(define-cstruct _lock
  ([path _path]
   [token _bytes]
   [owner _string/utf-8]
   [comment _string/utf-8]
   [dav-comment? _bool]
   [creation-time _int64]
   [expiration-time _int64]))

(define-struct lock-info
  (path token owner comment creation-time expiration-time)
  #:transparent)

(define (lock->lock-info lock)
  (make-lock-info
   (lock-path lock)
   (lock-token lock)
   (lock-owner lock)
   (lock-comment lock)
   (apr-time->time-utc (lock-creation-time lock))
   (let ([micros (lock-expiration-time lock)])
     (if (= micros 0) #f (apr-time->time-utc micros)))))

(provide/contract
 (struct lock-info
         ([path path?]
          [token bytes?]
          [owner string?]
          [comment (or/c string? #f)]
          [creation-time time?]
          [expiration-time (or/c time? #f)])))

(define fs-lock!
  (wrapper-with-pool (fs path
                         #:token [token #f]
                         #:comment [comment #f]
                         #:expiration-time [expiration-time #f]
                         #:current-rev [current-rev #f]
                         #:steal [steal? #f])
    ((get-ffi-obj
      "svn_fs_lock" libsvn-fs
      (_fun [lock : (_ptr o _lock-pointer/null)]
            [fs : _fs] [path : _path] [token : _bytes]
            [comment : _string/utf-8] [dav-comment? : _bool = #f]
            [expiration-time : _int64]
            [current-rev : _long] [steal? : _bool]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-lock! error)
                 (lock->lock-info lock))))
     fs path token comment
     (if expiration-time
         (time-utc->apr-time
          (let ([type (time-type expiration-time)])
            (cond
              [(eq? type time-utc)
               expiration-time]
              [(eq? type time-duration)
               (add-duration! (current-time) expiration-time)]
              [else
               (raise-type-error 'fs-lock! "time-utc or time-duration" expiration-time)])))
         0)
     (or current-rev -1) steal?)))

(define fs-unlock!
  (wrapper-with-pool (fs path token)
    ((get-ffi-obj
      "svn_fs_unlock" libsvn-fs
      (_fun [fs : _fs] [path : _path] [token : _bytes]
            [break? : _bool = (not token)]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (check-error 'fs-unlock! error)))
     fs path token)))

(define (call-with-fs-lock fs path thunk
                           #:token [token #f]
                           #:comment [comment #f]
                           #:expiration-time [expiration-time #f]
                           #:current-rev [current-rev #f]
                           #:steal [steal? #f])
  (dynamic-wind
   (λ ()
     (let ([lock (fs-lock! fs path
                           #:token token
                           #:comment comment
                           #:expiration-time expiration-time
                           #:current-rev current-rev
                           #:steal steal?)])
       (set! token (lock-info-token lock))
       (fs-access-add-lock-token! (fs-access fs) token)))
   thunk
   (λ ()
     (fs-unlock! fs path token))))

(define fs-lock-info
  (wrapper-with-pool (fs path)
    ((get-ffi-obj
      "svn_fs_get_lock" libsvn-fs
      (_fun [lock : (_ptr o _lock-pointer/null)]
            [fs : _fs] [path : _path]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-lock-info error)
                 (cond
                   [lock
                    => lock->lock-info]
                   [else
                    #f]))))
     fs path)))

(define fs-list-locks
  (local [(define fs-list-locks*
            (get-ffi-obj
             "svn_fs_get_locks" libsvn-fs
             (_fun [fs : _fs] [path : _path]
                   [proc : (_fun [baton : _pointer]
                                 [lock : _lock-pointer]
                                 [pool : _pool]
                                 -> [error : _error/null])]
                   [baton : _pointer = #f]
                   [pool : _pool = (current-pool)]
                   -> [error : _error/null]
                   -> (check-error 'fs-list-locks error))))]
    (λ (fs path)
      (let ([locks '()])
        (parameterize ([current-pool (make-pool)])
          (fs-list-locks*
           fs path
           (λ (baton lock pool)
             (set! locks (cons (lock->lock-info lock) locks))
             #f)))
        locks))))

(provide
 fs-lock! fs-unlock! call-with-fs-lock fs-lock-info fs-list-locks)

;;; Transactions

(define-cpointer-type _fs-txn _pooled-pointer)

(provide _fs-txn _fs-txn/null fs-txn?)

(define fs-begin-txn
  (wrapper-with-pool (fs rev)
    ((get-ffi-obj
      "svn_fs_begin_txn2" libsvn-fs
      (_fun [txn : (_ptr o _fs-txn/null)]
            [fs : _fs] [rev : _long]
            [flags : _uint32 = 3]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-begin-txn error)
                 txn)))
     fs rev)))

(define fs-open-txn
  (wrapper-with-pool (fs txn-name)
    ((get-ffi-obj
      "svn_fs_open_txn" libsvn-fs
      (_fun [txn : (_ptr o _fs-txn/null)]
            [fs : _fs] [txn-name : _bytes]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-open-txn error)
                 txn)))
     fs txn-name)))

(define fs-commit-txn
  (wrapper-with-pool (txn)
    ((get-ffi-obj
      "svn_fs_commit_txn" libsvn-fs
      (_fun [conflict : _pointer = #f]
            [new-rev : (_ptr o _long)]
            [txn : _fs-txn]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-commit-txn error)
                 new-rev)))
     txn)))

(define fs-abort-txn
  (wrapper-with-pool (txn)
    ((get-ffi-obj
      "svn_fs_abort_txn" libsvn-fs
      (_fun [txn : _fs-txn]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (check-error 'fs-abort-txn error)))
     txn)))

(define fs-purge-txn
  (wrapper-with-pool (fs txn-name)
    ((get-ffi-obj
      "svn_fs_purge_txn" libsvn-fs
      (_fun [fs : _fs]
            [txn-name : _bytes]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (check-error 'fs-purge-txn error)))
     fs txn-name)))

(define fs-txn-name
  (wrapper-with-pool (txn)
    ((get-ffi-obj
      "svn_fs_txn_name" libsvn-fs
      (_fun [txn-name : (_ptr o _bytes)]
            [txn : _fs-txn]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-txn-name error)
                 txn-name)))
     txn)))

(define fs-txn-base-rev
  (get-ffi-obj
   "svn_fs_txn_base_revision" libsvn-fs
   (_fun [txn : _fs-txn]
         -> [rev : _long])))

(define set-fs-txn-prop!
  (wrapper-with-pool (txn prop-name value)
    ((get-ffi-obj
      "svn_fs_change_txn_prop" libsvn-fs
      (_fun [txn : _fs-txn] [prop-name : _symbol]
            [value : _svn-string-pointer/null]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (check-error 'set-fs-txn-prop! error)))
     txn prop-name (bytes->svn-string value))))

(define fs-txn-prop
  (getter-with-setter
   (wrapper-with-pool (txn prop-name)
     ((get-ffi-obj
       "svn_fs_txn_prop" libsvn-fs
       (_fun [value : (_ptr o _svn-string-pointer/null)]
             [txn : _fs-txn] [prop-name : _symbol]
             [pool : _pool = (current-pool)]
             -> [error : _error/null]
             -> (begin
                  (check-error 'fs-txn-prop error)
                  (svn-string->bytes value))))
      txn prop-name))
   set-fs-txn-prop!))

(define fs-list-txn-props
  (wrapper-with-pool (txn)
    ((get-ffi-obj
      "svn_fs_txn_proplist" libsvn-fs
      (_fun [hash : (_ptr o _apr-hash/null)]
            [txn : _fs-txn]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-list-txn-props error)
                 (map (compose string->symbol bytes->string/utf-8)
                      (apr-hash->keys hash)))))
     txn)))
  
(define fs-list-txns
  (wrapper-with-pool (fs)
    ((get-ffi-obj
      "svn_fs_list_transactions" libsvn-fs
      (_fun [names : (_ptr o _array-header-pointer/null)]
            [fs : _fs]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-list-txns error)
                 (cvector->list (array-header->cvector names _bytes)))))
     fs)))

(define (call-with-fs-txn fs rev proc)
  (let* ([txn (fs-begin-txn fs rev)])
    (apply
     values
     (dynamic-wind
      void
      (λ ()
        (let* ([results (call-with-values
                         (λ ()
                           (proc txn))
                         (λ (first-result . more-results)
                           (if (void? first-result)
                               more-results
                               (cons first-result more-results))))]
               [new-rev (fs-commit-txn txn)])
          (set! txn #f)
          (cons new-rev results)))
      (λ ()
        (when txn
          (fs-abort-txn txn)
          (set! txn #f)))))))

(provide
 fs-begin-txn fs-open-txn fs-commit-txn fs-abort-txn fs-purge-txn
 fs-txn-name fs-txn-base-rev fs-txn-prop set-fs-txn-prop!
 fs-list-txn-props fs-list-txns call-with-fs-txn)

;;; File system roots

(define-cpointer-type _fs-root _pooled-pointer)

(provide _fs-root _fs-root/null fs-root?)

(define fs-rev-root
  (wrapper-with-pool (fs rev)
    ((get-ffi-obj
      "svn_fs_revision_root" libsvn-fs
      (_fun [root : (_ptr o _fs-root/null)]
            [fs : _fs] [rev : _long]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-rev-root error)
                 root)))
     fs rev)))

(define fs-rev-root?
  (get-ffi-obj
   "svn_fs_is_revision_root" libsvn-fs
   (_fun [root : _fs-root]
         -> _bool)))

(define fs-rev-root-rev
  (get-ffi-obj
   "svn_fs_revision_root_revision" libsvn-fs
   (_fun [root : _fs-root]
         -> _long)))

(define fs-txn-root
  (wrapper-with-pool (txn)
    ((get-ffi-obj
      "svn_fs_txn_root" libsvn-fs
      (_fun [root : (_ptr o _fs-root/null)]
            [txn : _fs-txn]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-txn-root error)
                 root)))
     txn)))

(define fs-txn-root?
  (get-ffi-obj
   "svn_fs_is_txn_root" libsvn-fs
   (_fun [root : _fs-root]
         -> _bool)))

(define fs-txn-root-name
  (wrapper-with-pool (root)
    ((get-ffi-obj
      "svn_fs_txn_root_name" libsvn-fs
      (_fun [root : _fs-root]
            [pool : _pool = (current-pool)]
            -> _bytes))
     root)))

(define fs-root-fs
  (local [(define fs-root-fs*
            (get-ffi-obj
             "svn_fs_root_fs" libsvn-fs
             (_fun [root : _fs-root]
                   -> [fs : _fs])))]
    (λ (root)
      (parameterize ([current-pool (pointer-pool root)])
        (fs-root-fs* root)))))

(provide
 fs-rev-root fs-rev-root? fs-rev-root-rev
 fs-txn-root fs-txn-root? fs-txn-root-name fs-root-fs)

;;; Node management

(define fs-make-directory
  (wrapper-with-pool (root path)
    ((get-ffi-obj
      "svn_fs_make_dir" libsvn-fs
      (_fun [root : _fs-root] [path : _path]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (check-error 'fs-make-directory error)))
     root path)))

(define fs-make-file*
  (get-ffi-obj
   "svn_fs_make_file" libsvn-fs
   (_fun [root : _fs-root] [path : _path]
         [pool : _pool = (current-pool)]
         -> [error : _error/null]
         -> (check-error 'fs-make-file error))))

(define (fs-make-file root path)
  (parameterize ([current-pool (make-pool)])
    (fs-make-file* root path)))

(define fs-copy-node
  (wrapper-with-pool (src-root src-path tgt-root tgt-path)
    ((get-ffi-obj
      "svn_fs_copy" libsvn-fs
      (_fun [src-root : _fs-root] [src-path : _path]
            [tgt-root : _fs-root] [tgt-path : _path]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (check-error 'fs-copy-node error)))
     src-root src-path tgt-root tgt-path)))

(define fs-rev-link-node
  (wrapper-with-pool (src-root tgt-root path)
    ((get-ffi-obj
      "svn_fs_revision_link" libsvn-fs
      (_fun [src-root : _fs-root] [tgt-root : _fs-root]
            [path : _path]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (check-error 'fs-rev-link-node error)))
     src-root tgt-root path)))

(define fs-merge-nodes
  (wrapper-with-pool (src-root src-path tgt-root tgt-path ancestor-root ancestor-path)
    ((get-ffi-obj
      "svn_fs_merge" libsvn-fs
      (_fun [conflict : _pointer = #f]
            [src-root : _fs-root] [src-path : _path]
            [tgt-root : _fs-root] [tgt-path : _path]
            [ancestor-root : _fs-root] [ancestor-path : _path]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (check-error 'fs-merge-nodes error)))
     src-root src-path tgt-root tgt-path
     ancestor-root ancestor-path)))

(define fs-delete-node
  (wrapper-with-pool (root path)
    ((get-ffi-obj
      "svn_fs_delete" libsvn-fs
      (_fun [root : _fs-root] [path : _path]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (check-error 'fs-delete-node error)))
     root path)))

(provide
 fs-make-directory fs-make-file fs-copy-node fs-rev-link-node
 fs-merge-nodes fs-delete-node)

;;; Information about nodes in the filesystem

(define _fs-node-kind
  (_enum '(none file dir unknown)))

(provide _fs-node-kind)

(define fs-node-kind
  (wrapper-with-pool (root path)
    ((get-ffi-obj
      "svn_fs_check_path" libsvn-fs
      (_fun [kind : (_ptr o _fs-node-kind)]
            [root : _fs-root] [path : _path]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-node-kind error)
                 kind)))
     root path)))

(define fs-node-directory?
  (wrapper-with-pool (root path)
    ((get-ffi-obj
      "svn_fs_is_dir" libsvn-fs
      (_fun [ok? : (_ptr o _bool)]
            [root : _fs-root] [path : _path]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-node-directory? error)
                 ok?)))
     root path)))

(define fs-node-file?
  (wrapper-with-pool (root path)
    ((get-ffi-obj
      "svn_fs_is_file" libsvn-fs
      (_fun [ok? : (_ptr o _bool)]
            [root : _fs-root] [path : _path]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-node-file? error)
                 ok?)))
     root path)))

(define fs-node-created-rev
  (wrapper-with-pool (root path)
    ((get-ffi-obj
      "svn_fs_node_created_rev" libsvn-fs
      (_fun [rev : (_ptr o _long)]
            [root : _fs-root] [path : _path]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-node-created-rev error)
                 (if (>= rev 0) rev #f))))
     root path)))

(define fs-node-created-path
  (wrapper-with-pool (root path)
    ((get-ffi-obj
      "svn_fs_node_created_path" libsvn-fs
      (_fun [created-path : (_ptr o _path)]
            [root : _fs-root] [path : _path]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-node-created-path error)
                 created-path)))
     root path)))

(define fs-node-copied-from
  (wrapper-with-pool (root path)
    ((get-ffi-obj
      "svn_fs_copied_from" libsvn-fs
      (_fun [copied-rev : (_ptr o _long)]
            [copied-path : (_ptr o _path)]
            [root : _fs-root] [path : _path]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-node-copied-from error)
                 (values (if (>= copied-rev 0) copied-rev #f)
                         copied-path))))
     root path)))

(define fs-node-closest-copy
  (wrapper-with-pool (root path)
    ((get-ffi-obj
      "svn_fs_closest_copy" libsvn-fs
      (_fun [copied-root : (_ptr o _fs-root/null)]
            [copied-path : (_ptr o _path)]
            [root : _fs-root] [path : _path]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-node-closest-copy error)
                 (values copied-root
                         copied-path))))
     root path)))

(define fs-directory-list
  (wrapper-with-pool (root path)
    ((get-ffi-obj
      "svn_fs_dir_entries" libsvn-fs
      (_fun [hash : (_ptr o _apr-hash/null)]
            [root : _fs-root] [path : _path]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-directory-list error)
                 (map bytes->path-element (apr-hash->keys hash)))))
     root path)))

(define fs-file-length
  (wrapper-with-pool (root path)
    ((get-ffi-obj
      "svn_fs_file_length" libsvn-fs
      (_fun [length : (_ptr o _int64)]
            [root : _fs-root] [path : _path]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-file-length error)
                 length)))
     root path)))

(define fs-file-contents-changed?
  (wrapper-with-pool (src-root src-path tgt-root tgt-path)
    ((get-ffi-obj
      "svn_fs_contents_changed" libsvn-fs
      (_fun [changed? : (_ptr o _bool)]
            [src-root : _fs-root] [src-path : _path]
            [tgt-root : _fs-root] [tgt-path : _path]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-file-contents-changed? error)
                 changed?)))
     src-root src-path tgt-root tgt-path)))

(provide
 fs-node-kind fs-node-directory? fs-node-file?
 fs-node-created-rev fs-node-created-path
 fs-node-copied-from fs-node-closest-copy
 fs-directory-list fs-file-length fs-file-contents-changed?)

;;; Node properties

(define set-fs-node-prop!
  (wrapper-with-pool (root path prop-name value)
    ((get-ffi-obj
      "svn_fs_change_node_prop" libsvn-fs
      (_fun [root : _fs-root] [path : _path]
            [prop-name : _symbol]
            [value : _svn-string-pointer/null]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (check-error 'set-fs-node-prop! error)))
     root path prop-name (bytes->svn-string value))))

(define fs-node-prop
  (getter-with-setter
   (wrapper-with-pool (root path prop-name)
     ((get-ffi-obj
       "svn_fs_node_prop" libsvn-fs
       (_fun [value : (_ptr o _svn-string-pointer/null)]
             [root : _fs-root] [path : _path]
             [prop-name : _symbol]
             [pool : _pool = (current-pool)]
             -> [error : _error/null]
             -> (begin
                  (check-error 'fs-node-prop error)
                  (svn-string->bytes value))))
      root path prop-name))
   set-fs-node-prop!))

(define fs-list-node-props
  (wrapper-with-pool (root path)
    ((get-ffi-obj
      "svn_fs_node_proplist" libsvn-fs
      (_fun [hash : (_ptr o _apr-hash/null)]
            [root : _fs-root] [path : _path]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-list-node-props error)
                 (map (compose string->symbol bytes->string/utf-8)
                      (apr-hash->keys hash)))))
     root path)))

(provide fs-node-prop set-fs-node-prop! fs-list-node-props)

;;; History information

(define-cpointer-type _fs-history _pooled-pointer)

(provide _fs-history _fs-history/null fs-history?)

(define fs-node-history
  (wrapper-with-pool (root path)
    ((get-ffi-obj
      "svn_fs_node_history" libsvn-fs
      (_fun [history : (_ptr o _fs-history/null)]
            [root : _fs-root] [path : _path]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-node-history error)
                 history)))
     root path)))

(define fs-history-prev
  (wrapper-with-pool (history cross-copies?)
    ((get-ffi-obj
      "svn_fs_history_prev" libsvn-fs
      (_fun [prev-history : (_ptr o _fs-history/null)]
            [history : _fs-history] [cross-copies? : _bool]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-history-prev error)
                 prev-history)))
     history cross-copies?)))

(define fs-history-location
  (wrapper-with-pool (history)
    ((get-ffi-obj
      "svn_fs_history_location" libsvn-fs
      (_fun [path : (_ptr o _path)] [rev : (_ptr o _long)]
            [history : _fs-history]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'fs-history-location error)
                 (values rev path))))
     history)))

(provide fs-node-history fs-history-prev fs-history-location)

;;; Delta management

(define-cpointer-type _window-handler)

(define-cpointer-type _baton _pooled-pointer)

(define txdelta-target-push*
  (get-ffi-obj
   "svn_txdelta_target_push" libsvn-delta
   (_fun [handler : _window-handler]
         [baton : _baton/null]
         [source : _stream]
         [pool : _pool = (current-pool)]
         -> [target : _stream])))

;;; Node data access

(define fs-file-contents*
  (get-ffi-obj
   "svn_fs_file_contents" libsvn-fs
   (_fun [stream : (_ptr o _stream/null)]
         [root : _fs-root] [path : _path]
         [pool : _pool = (current-pool)]
         -> [error : _error/null]
         -> (begin
              (check-error 'fs-open-input-file error)
              stream))))

(define fs-apply-text*
  (get-ffi-obj
   "svn_fs_apply_text" libsvn-fs
   (_fun [stream : (_ptr o _stream/null)]
         [root : _fs-root] [path : _path]
         [base-checksum : _bytes]
         [pool : _pool = (current-pool)]
         -> [error : _error/null]
         -> (begin
              (check-error 'fs-open-output-file error)
              stream))))

(define fs-apply-textdelta*
  (get-ffi-obj
   "svn_fs_apply_textdelta" libsvn-fs
   (_fun [handler : (_ptr o _window-handler/null)]
         [baton : (_ptr o _baton/null)]
         [root : _fs-root] [path : _path]
         [base-checksum : _bytes]
         [result-checksum : _bytes]
         [pool : _pool = (current-pool)]
         -> [error : _error/null]
         -> (begin
              (check-error 'fs-open-output-file error)
              (values handler baton)))))

(define (fs-apply-push* root path base-checksum result-checksum)
  (let-values ([(handler baton) (fs-apply-textdelta* root path
                                                     base-checksum
                                                     result-checksum)])
    (txdelta-target-push* handler baton (fs-file-contents* root path))))

(define (fs-open-input-file root path)
  (nest [(let ([path (build-path path)]))
         (parameterize ([current-pool (make-pool)]))]
    (stream->input-port path (fs-file-contents* root path))))

(define (fs-open-output-file root path
                             #:deltify [deltify? #t]
                             #:base-checksum [base-checksum #f]
                             #:result-checksum [result-checksum #f])
  (nest [(let ([path (build-path path)]))
         (parameterize ([current-pool (make-pool)]))]
    (stream->output-port
     path
     (if deltify?
         (fs-apply-push* root path base-checksum result-checksum)
         (fs-apply-text* root path result-checksum)))))

(provide fs-open-input-file fs-open-output-file)

(define (call-with-fs-input-file root path proc)
  (let* ([in (fs-open-input-file root path)]
         [results (call-with-values
                   (λ ()
                     (proc in))
                   list)])
    (close-input-port in)
    (apply values results)))

(define (call-with-fs-output-file root path proc
                                  #:deltify [deltify? #t]
                                  #:base-checksum [base-checksum #f]
                                  #:result-checksum [result-checksum #f])
  (let* ([out (fs-open-output-file root path
                                   #:deltify deltify?
                                   #:base-checksum base-checksum
                                   #:result-checksum result-checksum)]
         [results (call-with-values
                   (λ ()
                     (proc out))
                   list)])
    (close-output-port out)
    (apply values results)))

(define (call-with-fs-input-file* root path proc)
  (let ([in (fs-open-input-file root path)])
    (dynamic-wind
     void
     (λ ()
       (proc in))
     (λ ()
       (close-input-port in)))))

(define (call-with-fs-output-file* root path proc
                                   #:deltify [deltify? #t]
                                   #:base-checksum [base-checksum #f]
                                   #:result-checksum [result-checksum #f])
  (let ([out (fs-open-output-file root path
                                  #:deltify deltify?
                                  #:base-checksum base-checksum
                                  #:result-checksum result-checksum)])
    (dynamic-wind
     void
     (λ ()
       (proc out))
     (λ ()
       (close-output-port out)))))

(define (with-fs-input-from-file root path thunk)
  (call-with-fs-input-file*
   root path
   (λ (in)
     (parameterize ([current-input-port in])
       (thunk)))))

(define (with-fs-output-to-file root path thunk
                                #:deltify [deltify? #t]
                                #:base-checksum [base-checksum #f]
                                #:result-checksum [result-checksum #f])
  (call-with-fs-output-file*
   root path
   #:deltify deltify?
   #:base-checksum base-checksum
   #:result-checksum result-checksum
   (λ (out)
     (parameterize ([current-output-port out])
       (thunk)))))

(provide
 call-with-fs-input-file call-with-fs-output-file
 call-with-fs-input-file* call-with-fs-output-file*
 with-fs-input-from-file with-fs-output-to-file)