#lang scheme
(require
 (only-in srfi/1 unfold)
 srfi/19
 scheme/foreign
 (only-in scheme/contract [-> ->/c]))
(unsafe!)

(define libapr
  (ffi-lib "libapr-1"))

;;; Helpers for error handling

(define strerror
  (get-ffi-obj "apr_strerror" libapr
               (_fun [status : _int]
                     [buffer : (_bytes o size)] [size : _ulong = 256]
                     -> [message : _string/utf-8])))

(define-struct (exn:fail:apr exn:fail)
  (status)
  #:transparent)

(define (check-status source status)
  (unless (= status 0)
    (raise (make-exn:fail:apr
            (format "~a: ~a" source (strerror status))
            (current-continuation-marks)
            status))))

(provide/contract
 (struct (exn:fail:apr exn:fail)
         ([message string?]
          [continuation-marks continuation-mark-set?]
          [status exact-integer?])))

(provide*
 (unsafe check-status))

;;; Library initialization

(define initialize
  (get-ffi-obj "apr_initialize" libapr
               (_fun
                -> [status : _int]
                -> (check-status 'initialize status))))

(initialize)

;;; Pointers with attached pools.

(define pooled-pointer-tag
  "pooled")

(define _pooled-pointer
  (_cpointer/null pooled-pointer-tag _pointer
                  values
                  (λ (ptr)
                    (when ptr
                      (set-cpointer-tag! ptr
                        (list* pooled-pointer-tag (current-pool)
                               (remove pooled-pointer-tag
                                       (let ([tag (cpointer-tag ptr)])
                                         (if (pair? tag) tag (list tag)))))))
                    ptr)))

(define (pooled-pointer? obj)
  (and (cpointer? obj)
       (cpointer-has-tag? obj pooled-pointer-tag)))

(define (pointer-pool obj)
  (cond
    [(pooled-pointer? obj)
     => cadr]
    [else
     #f]))

(provide _pooled-pointer pooled-pointer? pointer-pool)

;;; Memory pools

(define-cpointer-type _pool _pooled-pointer)

(provide _pool _pool/null pool?)

(define current-pool
  (make-parameter #f))

(provide/contract
 [current-pool (parameter/c (or/c pool? #f))])

(define make-pool
  (local [(define make-pool*
            (get-ffi-obj
             "apr_pool_create_ex" libapr
             (_fun [pool : (_ptr o _pool/null)] [parent : _pool/null]
                   [abort : _pointer = #f] [alloc : _pointer = #f]
                    -> [status : _int]
                    -> (begin
                         (check-status 'make-pool status)
                         pool))))
          (define pool-destroy
            (get-ffi-obj
             "apr_pool_destroy" libapr
             (_fun [pool : _pool]
                   -> _void)))]
    (λ ([parent (current-pool)])
      (nest [(parameterize-break #f)
             (parameterize ([current-pool parent]))]
        (let ([pool (make-pool* parent)])
          (register-finalizer pool pool-destroy)
          pool)))))

(provide make-pool)

;;; Wrapper generator to provide a pool for a foreign function.

(define-syntax wrapper-with-pool
  (syntax-rules ()
    [(wrapper-with-pool lambda-list (proc-expr arg-exprs ...))
     (let ([proc proc-expr])
       (λ lambda-list
         (parameterize ([current-pool (make-pool)])
           (proc arg-exprs ...))))]))

(provide wrapper-with-pool)

;;; Allocation helpers

(define bytes-copy/pool
  (get-ffi-obj
   "apr_pstrmemdup" libapr
   (_fun [pool : _pool = (current-pool)]
         [bytes : _bytes] [length : _ulong = (bytes-length bytes)]
         -> [copy : _pooled-pointer])))

(provide bytes-copy/pool)

;;; Arrays

(define-cstruct _array-header
  ([pool _pool]
   [element-size _int]
   [element-count _int]
   [allocation-count _int]
   [elements _pointer]))

(define (array-header->cvector header type)
  (let ([element-size (array-header-element-size header)])
    (unless (= (ctype-sizeof type) element-size)
      (raise-type-error 'array-header->cvector
                        (format "ctype of size ~a" element-size)
                        type)))
  (make-cvector* (array-header-elements header)
                 type
                 (array-header-element-count header)))

(provide*
 _array-header _array-header-pointer _array-header-pointer/null
 array-header? (unsafe make-array-header)
 (unsafe array-header-pool) array-header-element-size
 array-header-element-count array-header-allocation-count
 array-header-elements (unsafe array-header->cvector))

;;; Hashtables

(define-cpointer-type _apr-hash _pooled-pointer)

(define-cpointer-type _apr-hash-index _pooled-pointer)

(provide
 _apr-hash _apr-hash/null apr-hash?
 _apr-hash-index _apr-hash-index/null apr-hash-index?)

(define apr-hash-first
  (wrapper-with-pool (hash)
    ((get-ffi-obj
      "apr_hash_first" libapr
      (_fun [pool : _pool = (current-pool)]
            [hash : _apr-hash]
            -> [index : _apr-hash-index/null]))
     hash)))

(define apr-hash-next
  (local [(define apr-hash-next*
            (get-ffi-obj
             "apr_hash_next" libapr
             (_fun [index : _apr-hash-index]
                   -> [next-index : _apr-hash-index/null])))]
    (λ (index)
      (parameterize ([current-pool (pointer-pool index)])
        (apr-hash-next* index)))))

(define apr-hash-this
  (get-ffi-obj
   "apr_hash_this" libapr
   (_fun [index : _apr-hash-index]
         [key : (_ptr o _pointer)] [length : (_ptr o _int)]
         [value : (_ptr o _pointer)]
         -> _void
         -> (values (bytes-copy (make-sized-byte-string key length))
                    value))))

(define (apr-hash->keys hash)
  (unfold
   not
   (λ (index)
     (let-values ([(key value) (apr-hash-this index)])
       key))
   apr-hash-next
   (apr-hash-first hash)))

(provide apr-hash->keys)

;;; Time

(define (apr-time->time-utc time)
  (let-values ([(seconds micros) (quotient/remainder time #e1e6)])
    (make-time time-utc (* micros #e1e3) seconds)))

(define (time-utc->apr-time time)
  (unless (eq? (time-type time) time-utc)
    (raise-type-error 'time-utc->apr-time "time-utc" time))
  
  (let ([seconds (time-second time)]
        [nanos (time-nanosecond time)])
    (+ (* seconds #e1e6) (quotient nanos #e1e3))))

(provide/contract
 [apr-time->time-utc (->/c exact-integer? time?)]
 [time-utc->apr-time (->/c time? exact-integer?)])

(define-unsafer unsafe-apr!)