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

Last change on this file since 15492 was 15492, checked in by sjamaan, 11 years ago

Fix handling of directories - it was a mess before, it's better but slower now

File size: 5.3 KB
Line 
1;;
2;; qwiki-svn - Subversion implementation of revisioning system for qwiki
3;;
4;; Copyright (c) 2009 Peter Bex
5;;
6;;  Redistribution and use in source and binary forms, with or without
7;;  modification, are permitted provided that the following conditions
8;;  are met:
9;;
10;;  - Redistributions of source code must retain the above copyright
11;;  notice, this list of conditions and the following disclaimer.
12;;
13;;  - Redistributions in binary form must reproduce the above
14;;  copyright notice, this list of conditions and the following
15;;  disclaimer in the documentation and/or other materials provided
16;;  with the distribution.
17;;
18;;  - Neither name of the copyright holders nor the names of its
19;;  contributors may be used to endorse or promote products derived
20;;  from this software without specific prior written permission.
21;;
22;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE
23;;  CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
24;;  INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
25;;  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
26;;  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE
27;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
28;;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
29;;  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
30;;  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
31;;  AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
32;;  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
33;;  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34;;  POSSIBILITY OF SUCH DAMAGE.
35
36(provide 'qwiki-svn)
37
38(module qwiki-svn
39  (qwiki-repos-uri qwiki-repos-username qwiki-repos-password
40   get-history call-with-input-revision checkout-sources! update-sources!
41   store-changes! undo-changes!)
42
43(import chicken scheme)
44(use regex posix files srfi-18 svn-client)
45
46;; The version control system's repos uri, username and password
47(define qwiki-repos-uri (make-parameter #f)) ; string, not uri-reference!
48(define qwiki-repos-username (make-parameter "anonymous"))
49(define qwiki-repos-password (make-parameter ""))
50
51;; Get the history for a given file starting at rev, going back in
52;; time.  If rev is #f, start at the latest revision.  If limit is not
53;; specified or #f, the full history is returned.  Otherwise, a
54;; maximum of that many items is returned.
55(define (get-history file rev #!optional limit)
56  (let ((history '()))
57    (svn-client-log2
58     file (if rev (make-svn-opt-revision-number rev) svn-opt-revision-head)
59     (make-svn-opt-revision-number 0) (or limit 0) #f #f
60     (qwiki-repos-username) (qwiki-repos-password)
61     (lambda (files rev author date msg)
62       ;; What about the timezone?  Is it always GMT?  POSIX strptime
63       ;; doesn't know about this so we may need to use srfi-19...
64       (let* ((seconds-date (string-substitute "\\.[0-9]+.*" "" date))
65              (date (string->time date "%Y-%m-%dT%H:%M")))
66         (set! history (cons (list rev author date msg) history)))))
67    (reverse history)))
68
69(define (call-with-input-revision file rev proc)
70  (let ((filename (svn-client-cat
71                   file (make-svn-opt-revision-number rev)
72                   (qwiki-repos-username) (qwiki-repos-password))))
73    (handle-exceptions exn
74      (begin
75        (delete-file* filename)
76        (raise exn))
77      (let ((result (call-with-input-file filename proc)))
78        (delete-file* filename)
79        result))))
80
81(define (checkout-sources! source-path)
82  (svn-update (qwiki-repos-uri) source-path svn-opt-revision-head
83              (qwiki-repos-username) (qwiki-repos-password)))
84
85(define (update-sources! source-path)
86  (if (and (file-exists? source-path)
87           (not (directory? source-path)))
88      (update-sources! (pathname-directory source-path))
89      (svn-update (qwiki-repos-uri) source-path svn-opt-revision-head
90                  (qwiki-repos-username) (qwiki-repos-password))))
91
92(define (get-info path)
93  (let ((info '()))
94    (svn-client-info path
95                     svn-opt-revision-unspecified
96                     svn-opt-revision-unspecified
97                     (lambda (path i) (set! info (cons i info)))
98                     #f (qwiki-repos-username) (qwiki-repos-password))
99    (and (not (null? info)) (car info))))
100
101(define (store-changes! source-path message username password)
102  (or
103   (let* ((user (or username (qwiki-repos-username)))
104          (pass (or password (qwiki-repos-password))))
105     (let loop ((source-path source-path))
106       (if (get-info source-path)
107           (svn-commit source-path user pass message)
108           (begin
109             (loop (pathname-directory source-path)) ; Add parent dirs if needed
110             (svn-add source-path user pass)
111             (svn-commit source-path user pass message)))))
112   (error "Could not store changes")))
113
114(define (undo-changes! source-path)
115  (if (get-info source-path)            ; Existing file?
116      (svn-client-revert (list source-path) #t
117                         (qwiki-repos-username)
118                         (qwiki-repos-password))
119      (begin
120        (delete-file* source-path)
121        (let loop ((path (pathname-directory source-path)))
122          (unless (get-info path)
123            (begin
124              (delete-directory path)
125              (loop (pathname-directory path))))))))
126
127)
Note: See TracBrowser for help on using the repository browser.