#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-client
  (ffi-lib "libsvn_client-1"))

;;; Client context management

(define-cpointer-type _client _pooled-pointer)

(provide _client _client/null client?)

(define make-client
  (wrapper-with-pool ()
    ((get-ffi-obj
      "svn_client_create_context" libsvn-client
      (_fun [client : (_ptr o _client)] [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'make-client error)
                 (set-client-config!
                  client (make-client-config #f))
                 (set-client-auth!
                  client (make-client-auth
                          (or (getenv "USER") (getenv "LOGNAME") "nobody")
                          #f))
                 client))))))

(provide make-client)

;;; Configuration management

(define make-client-config
  (wrapper-with-pool* (config-dir)
    ((get-ffi-obj
      "svn_config_get_config" libsvn-client
      (_fun [config : (_ptr o _apr-hash)]
            [config-dir : _path]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'make-client-config error)
                 config)))
     (and config-dir (path->complete-path config-dir)))))

(define (set-client-config! client config)
  (unless (client? client)
    (raise-type-error 'set-client-config! "non-null `client' pointer" client))
  (unless (apr-hash? config)
    (raise-type-error 'set-client-config! "non-null `apr-hash' pointer" config))
  (let ([config (if (pool-ancestor? (pointer-pool config) (pointer-pool client))
                    config
                    (parameterize ([current-pool (pointer-pool client)])
                      (apr-hash-copy config)))])
    (ptr-set! client _apr-hash 'abs 20 config)))

(define client-config
  (getter-with-setter
   (λ (client)
     (unless (client? client)
       (raise-type-error 'client-config "non-null `client' pointer" client))
     (parameterize ([current-pool (pointer-pool client)])
       (ptr-ref client _apr-hash 'abs 20)))
   set-client-config!))

(provide make-client-config client-config set-client-config!)

;;; Authentication management

(define-cpointer-type _client-auth _pooled-pointer)

(provide _client-auth _client-auth/null client-auth?)

(define make-client-auth
  (wrapper-with-pool* (username
                       password
                       #:interactive [interactive? #f]
                       #:config-dir [config-dir #f]
                       #:auth-cache [auth-cache? #t])
    ((get-ffi-obj
      "svn_cmdline_setup_auth_baton" libsvn-client
      (_fun [auth-baton : (_ptr o _client-auth)]
            [non-interactive? : _bool]
            [username : _string/utf-8]
            [password : _string/utf-8]
            [config-dir : _path]
            [no-auth-cache? : _bool]
            [config : _pointer = #f]
            [cancel-func : _fpointer = #f]
            [cancel-baton : _pointer = #f]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'make-client error)
                 auth-baton)))
     (not interactive?)
     username password
     (and config-dir (path->complete-path config-dir))
     (not auth-cache?))))

(define (set-client-auth! client auth)
  (unless (client? client)
    (raise-type-error 'set-client-auth! "non-null `client' pointer" client))
  (unless (client-auth? auth)
    (raise-type-error 'set-client-auth! "non-null `client-auth' pointer" auth))
  (unless (pool-ancestor? (pointer-pool auth) (pointer-pool client))
    (raise-mismatch-error 'set-client-auth! "expected `client-auth' pointer with allocation scope of `client' pointer; given " auth))
  (ptr-set! client _client-auth 'abs 0 auth))

(define client-auth
  (getter-with-setter
   (λ (client)
     (unless (client? client)
       (raise-type-error 'client-auth "non-null `client' pointer" client))
     (parameterize ([current-pool (pointer-pool client)])
       (ptr-ref client _client-auth)))
   set-client-auth!))

(provide make-client-auth client-auth set-client-auth!)

;;; Location and identification information

(define client-path->url
  (wrapper-with-pool (path)
    ((get-ffi-obj
      "svn_client_url_from_path" libsvn-client
      (_fun [url : (_ptr o _string/utf-8)] [path : _path]
	    [pool : _pool = (current-pool)]
	    -> [error : _error/null]
	    -> (begin
		 (check-error 'client-path->url error)
		 url)))
     (path->complete-path path))))

(define client-path->root-url
  (wrapper-with-pool (client path)
    ((get-ffi-obj
      "svn_client_root_url_from_path" libsvn-client
      (_fun [url : (_ptr o _string/utf-8)] [path : _path]
	    [client : _client] [pool : _pool = (current-pool)]
	    -> [error : _error/null]
	    -> (begin
		 (check-error 'client-path->root-url error)
		 url)))
     (if (path? path)
         (path->complete-path path)
         path)
     client)))

(define client-url-uuid
  (wrapper-with-pool (client url)
    ((get-ffi-obj
      "svn_client_uuid_from_url" libsvn-client
      (_fun [uuid : (_ptr o _bytes)] [url : _string/utf-8]
	    [client : _client] [pool : _pool = (current-pool)]
	    -> [error : _error/null]
	    -> (begin
		 (check-error 'client-url->uuid error)
		 uuid)))
     url client)))

(provide client-path->url client-path->root-url client-url-uuid)

;;; Revision specification

(define _revnum _long)

(define-cstruct _opt-revision-base
  ([kind (_enum '(unspecified revnum time committed previous base working head))]))

(define-cstruct (_opt-revision/revnum _opt-revision-base)
  ([revnum _revnum]))

(define-cstruct (_opt-revision/time _opt-revision-base)
  ([time _int64]))

(define _opt-revision
  (make-ctype
   _opt-revision-base-pointer
   (λ (revision)
     (cond
       [(number? revision)
	(make-opt-revision/revnum 'revnum revision)]
       [(time? revision)
	(make-opt-revision/time 'time (time-utc->apr-time revision))]
       [else
	(make-opt-revision/time revision 0)]))
   (λ (revision)
     (let ([kind (opt-revision-base-kind revision)])
       (case kind
	 [(revnum)
          (unless (opt-revision/revnum? revision)
            (cpointer-push-tag! revision opt-revision/revnum-tag))
	  (opt-revision/revnum-revnum revision)]
	 [(time)
          (unless (opt-revision/time? revision)
            (cpointer-push-tag! revision opt-revision/time-tag))
	  (apr-time->time-utc (opt-revision/time-time revision))]
	 [else
          kind])))))

(provide _revnum _opt-revision)

;;; Managing a checkout

(define client-checkout
  (wrapper-with-pool (client
		      url path
		      #:peg-revision [peg-revision 'unspecified]
		      #:revision [revision 'head]
                      #:recurse [recurse? #t]
		      #:ignore-externals [ignore-externals? #f])
    ((get-ffi-obj
      "svn_client_checkout2" libsvn-client
      (_fun [result-rev : (_ptr o _revnum)]
	    [url : _string/utf-8] [path : _path]
	    [peg-revision : _opt-revision] [revision : _opt-revision]
            [recurse? : _bool]
	    [ignore-externals? : _bool]
	    [client : _client]
	    [pool : _pool = (current-pool)]
	    -> [error : _error/null]
	    -> (begin
		 (check-error 'client-checkout error)
		 result-rev)))
     url (path->complete-path path)
     peg-revision revision
     recurse? ignore-externals?
     client)))

(define client-update
  (wrapper-with-pool (client
                      paths
		      #:revision [revision 'head]
                      #:recurse [recurse? #t]
		      #:ignore-externals [ignore-externals? #f])
    ((get-ffi-obj
      "svn_client_update2" libsvn-client
      (_fun [result-revs : (_ptr o _array-header-pointer)]
            [paths : _array-header-pointer]
            [revision : _opt-revision]
            [recurse? : _bool]
            [ignore-externals? : _bool]
            [client : _client]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'client-update error)
                 (cvector->list (array-header->cvector result-revs _revnum)))))
     (cvector->array-header
      (list->cvector (map path->complete-path paths) _path))
     revision recurse? ignore-externals?
     client)))

#|
(define _commit-info
  (_list-struct _revnum _string/utf-8 _string/utf-8 _string/utf-8))

(define client-commit
  (wrapper-with-pool (client
                      targets
                      #:recurse [recurse? #t]
                      #:keep-locks [keep-locks? #f])
    ((get-ffi-obj
      "svn_client_commit3" libsvn-client
      (_fun [commit-info : (_ptr o _commit-info)]
            [targets : _array-header-pointer]
            [recurse? : _bool]
            [keep-locks? : _bool]
            [client : _client]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'client-commit error)
                 (apply values commit-info))))
     (cvector->array-header
      (list->cvector (map path->complete-path targets) _path))
     recurse? keep-locks?
     client)))
|#

(provide client-checkout client-update #;client-commit)

;;; Listing files under version control

(define client-directory-list
  (wrapper-with-pool (client
                      path
                      #:peg-revision [peg-revision 'unspecified]
                      #:revision [revision 'head]
		      #:recurse [recurse? #f])
    ((get-ffi-obj
      "svn_client_ls3" libsvn-client
      (_fun [entries : (_ptr o _apr-hash)] [locks : (_ptr o _apr-hash)]
            [path : _path]
            [peg-revision : _opt-revision] [revision : _opt-revision]
            [recurse? : _bool]
            [client : _client]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'client-directory-list error)
                 (values
                  (map bytes->path-element (apr-hash->keys entries))
                  (map bytes->string/utf-8 (apr-hash->keys locks))))))
     (if (path? path)
         (path->complete-path path)
         path)
     peg-revision revision
     recurse?
     client)))

(provide client-directory-list)

;;; Accessing properties

(define-cstruct _property-list-item
  ([path _svn-stringbuf-pointer]
   [properties _apr-hash]))

(define (decode-property-key+value* key+value)
  (cons
   (string->symbol (bytes->string/utf-8 (car key+value)))
   (let ([value (cdr key+value)])
     (cpointer-push-tag! value svn-string-tag)
     (svn-string->bytes value))))

(define (decode-property-path+value* path+value)
  (cons
   (bytes->string/utf-8 (car path+value))
   (let ([value (cdr path+value)])
     (cpointer-push-tag! value svn-string-tag)
     (svn-string->bytes value))))

(define client-property-list
  (wrapper-with-pool (client
                      path
                      #:peg-revision [peg-revision 'unspecified]
                      #:revision [revision 'head]
                      #:recurse [recurse? #f])
    ((get-ffi-obj
      "svn_client_proplist2" libsvn-client
      (_fun [properties : (_ptr o _array-header-pointer)]
            [path : _path]
            [peg-revision : _opt-revision] [revision : _opt-revision]
            [recurse? : _bool]
            [client : _client]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'client-property-list error)
                 (map
                  (λ (item)
                    (cons
                     (bytes->string/utf-8
                      (svn-stringbuf->bytes
                       (property-list-item-path item)))
                     (map
                      decode-property-key+value*
                      (apr-hash->alist
                       (property-list-item-properties item)))))
                  (cvector->list
                   (array-header->cvector properties _property-list-item-pointer))))))
     (if (path? path)
         (path->complete-path path)
         path)
     peg-revision revision
     recurse?
     client)))

(define client-property-ref
  (wrapper-with-pool (client
                      path key
                      #:peg-revision [peg-revision 'unspecified]
                      #:revision [revision 'head]
                      #:recurse [recurse? #f])
    ((get-ffi-obj
      "svn_client_propget2" libsvn-client
      (_fun [properties : (_ptr o _apr-hash/null)]
            [key : _symbol] [path : _path]
            [peg-revision : _opt-revision] [revision : _opt-revision]
            [recurse? : _bool]
            [client : _client]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'client-property-ref error)
                 (if properties
                     (map
                      decode-property-path+value*
                      (apr-hash->alist properties))
                     '()))))
     key
     (if (path? path)
         (path->complete-path path)
         path)
     peg-revision revision
     recurse?
     client)))

(define client-revision-property-list
  (wrapper-with-pool (client url #:revision [revision 'head])
    ((get-ffi-obj
      "svn_client_revprop_list" libsvn-client
      (_fun [properties : (_ptr o _apr-hash/null)]
            [url : _string/utf-8]
            [revision : _opt-revision]
            [set-in-revision : (_ptr o _revnum)]
            [client : _client]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'client-revision-property-list error)
                 (cons
                  set-in-revision
                  (if properties
                      (map
                       decode-property-key+value*
                       (apr-hash->alist properties))
                      '())))))
     url revision client)))

(define client-revision-property-ref
  (wrapper-with-pool (client url key #:revision [revision 'head])
    ((get-ffi-obj
      "svn_client_revprop_get" libsvn-client
      (_fun [key : _symbol]
            [value : (_ptr o _svn-string-pointer/null)]
            [url : _string/utf-8]
            [revision : _opt-revision]
            [set-in-revision : (_ptr o _revnum)]
            [client : _client]
            [pool : _pool = (current-pool)]
            -> [error : _error/null]
            -> (begin
                 (check-error 'client-revision-property-ref error)
                 (if value
                     (cons set-in-revision (svn-string->bytes value))
                     #f))))
     key url revision client)))

(provide
 client-property-list client-property-ref
 client-revision-property-list client-revision-property-ref)