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

(define libsvn-subr
  (ffi-lib "libsvn_subr-1"))

;;; Helpers for error handling

(define-cstruct _error
  ([status _int]
   [message _string/utf-8]
   [child _error-pointer/null]
   [pool _pool]
   [file _string/utf-8]
   [line _long]))

(provide
 (rename-out [_error-pointer _error] [_error-pointer/null _error/null])
 error?)

(define-struct (exn:fail:svn exn:fail)
  (status
   child
   location)
  #:transparent
  #:property prop:exn:srclocs
  (rec (exn:fail:svn-srclocs exn)
    (cons (exn:fail:svn-location exn)
          (cond
            [(exn:fail:svn-child exn)
             => exn:fail:svn-srclocs]
            [else
             '()]))))

(define error-clear
  (get-ffi-obj
   "svn_error_clear" libsvn-subr
   (_fun (error : _error-pointer/null) -> _void)))

(define (check-error source error)
  (dynamic-wind
   void
   (λ ()
     (when error
       (raise
        ((rec (error->exn:fail:svn error)
           (make-exn:fail:svn
            (format "~a: ~a" source (error-message error))
            (current-continuation-marks)
            (error-status error)
            (cond
              [(error-child error)
               => error->exn:fail:svn]
              [else
               #f])
            (let ([file (error-file error)]
                  [line (error-line error)])
              (if file
                  (make-srcloc file (if (> line 0) line #f)
                               #f #f #f)
                  #f))))
         error))))
   (λ ()
     (error-clear error))))

(provide/contract
 (struct (exn:fail:svn exn:fail)
         ([message string?]
          [continuation-marks continuation-mark-set?]
          [status exact-integer?]
          [child (or/c exn:fail:svn? #f)]
          [location (or/c srcloc? #f)])))

(provide*
 (unsafe check-error))

;;; Subversion strings

(define-cstruct _svn-string
  ([data _pointer]
   [length _ulong]))

(define (bytes->svn-string bytes)
  (if bytes
      (make-svn-string bytes (bytes-length bytes))
      #f))

(define (svn-string->bytes str)
  (if str
      (bytes-copy
       (make-sized-byte-string (svn-string-data str)
                               (svn-string-length str)))
      #f))

(provide*
 _svn-string _svn-string-pointer _svn-string-pointer/null svn-string?
 (unsafe bytes->svn-string) (unsafe svn-string->bytes))

;;; Stream <- port adapters

(define-cpointer-type _stream _pooled-pointer)

(provide _stream _stream/null stream?)

(define stream-read
  (get-ffi-obj
   "svn_stream_read" libsvn-subr
   (_fun [stream : _stream]
         [buffer : _bytes] [length : (_ptr io _ulong) = (bytes-length buffer)]
         -> [error : _error-pointer/null]
         -> (begin
              (check-error 'stream-read error)
              length))))

(define stream-write
  (get-ffi-obj
   "svn_stream_write" libsvn-subr
   (_fun [stream : _stream]
         [buffer : _bytes] [length : (_ptr io _ulong) = (bytes-length buffer)]
         -> [error : _error-pointer/null]
         -> (begin
              (check-error 'stream-write error)
              length))))

(define stream-close
  (get-ffi-obj
   "svn_stream_close" libsvn-subr
   (_fun [stream : _stream]
         -> [error : _error-pointer/null]
         -> (check-error 'stream-close error))))

(define (stream->input-port name stream)
  (make-input-port name
                   (λ (bytes)
                     (let ([length (stream-read stream bytes)])
                       (if (> length 0)
                           length
                           eof)))
                   #f
                   (λ ()
                     (stream-close stream))))

(define (stream->output-port name stream)
  (make-output-port name
                    always-evt
                    (λ (bytes start end dont-block? enable-breaks?)
                      (stream-write stream (subbytes bytes start end)))
                    (λ ()
                      (stream-close stream))))

(provide stream->input-port stream->output-port)

;;; UUID Generation

(define genuuid
  (wrapper-with-pool ()
    ((get-ffi-obj
      "svn_uuid_generate" libsvn-subr
      (_fun [pool : _pool = (current-pool)]
            -> _bytes)))))

(provide genuuid)

(define-unsafer unsafe-subr!)