;; ;; qwiki-svn - Subversion implementation of revisioning system for qwiki ;; ;; Copyright (c) 2009-2017 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. (module qwiki-svn (qwiki-repos-uri qwiki-repos-username qwiki-repos-password get-history call-with-input-revision call-with-input-changeset checkout-sources! update-sources! store-changes! undo-changes! get-extended-property get-last-modified-revision) (import scheme svn-client (chicken time posix) (chicken base) (chicken condition) (chicken file) (chicken file posix) (chicken pathname) (chicken irregex)) ;; 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 (reverse (svn-client-log 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))))) (map (lambda (entry) ;; 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 (irregex-replace "\\.[0-9]+.*" (svn-log-date entry))) (date (string->time (svn-log-date entry) "%Y-%m-%dT%H:%M"))) (list (svn-log-revision entry) (svn-log-author entry) date (svn-log-message entry)))) history))) (define (call-with-file-to-remove filename proc) (handle-exceptions exn (begin (delete-file* filename) (signal exn)) (let ((result (call-with-input-file filename (lambda (f) (handle-exceptions exn (begin (close-input-port f) (signal exn)) (proc f)))))) (delete-file* filename) result))) (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)))) (unless filename (error "No such file" file)) (call-with-file-to-remove filename proc))) ;; This basically implements "svn diff -r:" (define (call-with-input-changeset source-path file rev1 rev2 proc) (let ((filename (svn-diff file (make-svn-opt-revision-number rev1) (make-svn-opt-revision-number rev2) source-path #t (qwiki-repos-username) (qwiki-repos-password)))) (unless filename (error "No such file" file)) (call-with-file-to-remove filename proc))) (define (checkout-sources! source-path) (svn-checkout (qwiki-repos-uri) source-path svn-opt-revision-head #t (qwiki-repos-username) (qwiki-repos-password))) (define (update-sources! source-path) (svn-update source-path svn-opt-revision-head #t (qwiki-repos-username) (qwiki-repos-password))) (define (get-last-modified-revision path) (and-let* ((i (get-info path))) (svn-info-last-changed-rev i))) (define (get-info path) (let ((info (svn-client-info path svn-opt-revision-unspecified svn-opt-revision-unspecified #f (qwiki-repos-username) (qwiki-repos-password)))) (and info (not (null? info)) (cadar info)))) (define (store-changes! source-path message username password) (or (let* ((user (or username (qwiki-repos-username))) (pass (or password (qwiki-repos-password)))) (let loop ((source-path source-path)) (if (get-info source-path) (svn-commit source-path #t user pass message) (begin (loop (pathname-directory source-path)) ; Add parent dirs if needed (svn-add source-path #t user pass) (svn-commit source-path #t user pass message))))) (error "Could not store changes"))) (define (undo-changes! source-path) (let ((info (get-info source-path))) (when info (svn-client-revert (list source-path) #t (qwiki-repos-username) (qwiki-repos-password))) ;; If file exists and is not under version control, or only has ;; been marked as added, we remove it (when (or (not info) (= (svn-info-rev info) (svn-opt-revision-number svn-opt-revision-unspecified))) (if (directory? source-path) (delete-directory source-path) (delete-file* source-path)) (let* ((parent-path (pathname-directory source-path)) (parent-info (get-info parent-path))) (unless (and parent-info (not (= (svn-info-rev parent-info) (svn-opt-revision-number svn-opt-revision-unspecified)))) (undo-changes! parent-path)))))) (define (get-extended-property path property) (and-let* ((retval (svn-propget property path svn-opt-revision-unspecified #t (qwiki-repos-username) (qwiki-repos-password))) (props (alist-ref path retval string=?)) (prop (car props))) prop)) )