source: project/release/4/qwiki/trunk/qwiki-svn.scm @ 15437

;; 
;; qwiki-svn - Subversion implementation of revisioning system for qwiki
;; 
;; Copyright (c) 2009 Peter Bex
;;
;;  Redistribution and use in source and binary forms, with or without
;;  modification, are permitted provided that the following conditions
;;  are met:
;; 
;;  - Redistributions of source code must retain the above copyright
;;  notice, this list of conditions and the following disclaimer.
;; 
;;  - Redistributions in binary form must reproduce the above
;;  copyright notice, this list of conditions and the following
;;  disclaimer in the documentation and/or other materials provided
;;  with the distribution.
;; 
;;  - Neither name of the copyright holders nor the names of its
;;  contributors may be used to endorse or promote products derived
;;  from this software without specific prior written permission.
;; 
;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE
;;  CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
;;  INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
;;  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;;  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE
;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;;  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
;;  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
;;  AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
;;  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
;;  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;  POSSIBILITY OF SUCH DAMAGE.

(provide 'qwiki-svn)

(module qwiki-svn
  (qwiki-repos-uri qwiki-repos-username qwiki-repos-password
   get-history call-with-input-revision checkout-sources! update-sources!
   store-changes!)

(import chicken scheme)
(use regex posix files srfi-18 svn-client)

;; The version control system's repos uri, username and password
(define qwiki-repos-uri (make-parameter #f)) ; string, not uri-reference!
(define qwiki-repos-username (make-parameter "anonymous"))
(define qwiki-repos-password (make-parameter ""))

;; Get the history for a given file starting at rev, going back in
;; time.  If rev is #f, start at the latest revision.  If limit is not
;; specified or #f, the full history is returned.  Otherwise, a
;; maximum of that many items is returned.
(define (get-history file rev #!optional limit)
  (let ((history '()))
    (svn-client-log2
     file (if rev (make-svn-opt-revision-number rev) svn-opt-revision-head)
     (make-svn-opt-revision-number 0) (or limit 0) #f #f
     (qwiki-repos-username) (qwiki-repos-password)
     (lambda (files rev author date msg)
       ;; What about the timezone?  Is it always GMT?  POSIX strptime
       ;; doesn't know about this so we may need to use srfi-19...
       (let* ((seconds-date (string-substitute "\\.[0-9]+.*" "" date))
              (date (string->time date "%Y-%m-%dT%H:%M")))
         (set! history (cons (list rev author date msg) history)))))
    (reverse history)))

(define (call-with-input-revision file rev proc)
  (let ((filename (svn-client-cat
                   file (make-svn-opt-revision-number rev)
                   (qwiki-repos-username) (qwiki-repos-password))))
    (handle-exceptions exn
      (begin
        (delete-file* filename)
        (raise exn))
      (let ((result (call-with-input-file filename proc)))
        (delete-file* filename)
        result))))

(define (checkout-sources! source-path)
  (svn-update (qwiki-repos-uri) source-path svn-opt-revision-head
              (qwiki-repos-username) (qwiki-repos-password)))

(define (update-sources! source-path)
  (svn-update (qwiki-repos-uri) source-path svn-opt-revision-head
              (qwiki-repos-username) (qwiki-repos-password)))

(define (store-changes! source-path message username password)
  (let* ((user (or username (qwiki-repos-username)))
         (pass (or password (qwiki-repos-password)))
         (get-info
          (lambda (path)
            (let ((info '()))
              (svn-client-info path
                               svn-opt-revision-unspecified
                               svn-opt-revision-unspecified
                               (lambda (path i) (set! info (cons i info)))
                               #f user pass)
              (and (not (null? info)) (car info))))))
   (let loop ((source-path source-path))
     (if (get-info source-path)
         (svn-commit source-path user pass message)
         (begin
           (loop (pathname-directory source-path)) ; Add parent dirs if needed
           (svn-add source-path user pass)
           (svn-commit source-path user pass message))))))

)