Changeset 13116 in project


Ignore:
Timestamp:
01/27/09 00:48:39 (11 years ago)
Author:
Alaric Snell-Pym
Message:

0.3 release - new backend, and fixed the .meta file typo

Location:
release/3/ugarit/trunk
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • release/3/ugarit/trunk/backend-fs.scm

    r13103 r13116  
    11(use gdbm)
     2(use srfi-69)
    23
    34(define (backend-fs base)
     
    221222            (gdbm-close *tags*)
    222223            (file-close *log*)))))
     224
     225(define (backend-splitlog logdir metadir max-logpart-size)
     226   (let*
     227        ((*index* (gdbm-open (string-append metadir "/index")))
     228         (*tags* (gdbm-open (string-append metadir "/tags")))
     229         (countfile (string-append metadir "/count"))
     230         (*logcount* (if (file-read-access? countfile)
     231            (with-input-from-file countfile read)
     232            0))
     233         (*log* (file-open (string-append logdir "/log" (number->string *logcount*))
     234                  (+ open/creat open/rdwr open/append) perm/irwxu))
     235         (*logfiles* (make-hash-table)) ; hash of file number to FD
     236         (get-log (lambda (index)
     237            (if (hash-table-exists? *logfiles* index)
     238               (hash-table-ref *logfiles* index)
     239               (begin
     240                  (let ((fd (file-open (string-append logdir "/log" (number->string index)) open/rdonly perm/irwxu)))
     241                     (set! (hash-table-ref *logfiles* index) fd)
     242                     fd)))))
     243         (make-index-key (lambda (key)
     244            key))
     245         (make-index-tag (lambda (tag)
     246            tag))
     247         (make-index-entry (lambda (type index posn len)
     248            (sprintf "(~A ~A ~A ~A)" type index posn len)))
     249         (parse-index-entry (lambda (str)
     250            (with-input-from-string str read))))
     251     
     252      ; FIXME: Sanity check that all opened OK
     253
     254      (make-storage
     255         (* 1024 1024) ; 1MiB blocks since local disk is fast and cheap
     256         #t ; We are writable
     257         #f ; We DO NOT support unlink!
     258         
     259         (lambda (key data type) ; put!
     260            (if (gdbm-exists *index* (make-index-key key))
     261               (signal (make-property-condition 'exn 'message "Duplicate block: put! should not be called on an existing hash" 'arguments (list key type))))
     262           
     263            (set-file-position! *log* 0 seek/end)
     264           
     265            ; FIXME: At this point, insert a nice recoverable header that can be used to
     266            ; reconstruct the index if required by scanning the log
     267           
     268            (let ((posn (file-position *log*)))
     269               (if (> posn max-logpart-size)
     270                  (begin
     271                     (file-close *log*)
     272                     (set! posn 0)
     273                     (set! *logcount* (+ *logcount* 1))
     274                     (with-output-to-file countfile (lambda ()
     275                        (write *logcount*)))
     276                     (set! *log* (file-open (string-append logdir "/log" (number->string *logcount*))
     277                                    (+ open/creat open/rdwr open/append) perm/irwxu))))
     278               (file-write *log* (u8vector->blob/shared data))
     279               (gdbm-store *index* (make-index-key key)
     280                  (make-index-entry type *logcount* posn (u8vector-length data)))
     281               (void)))
     282
     283         (lambda (key) ; exists?
     284            (if (gdbm-exists *index* (make-index-key key))
     285               (car (parse-index-entry (gdbm-fetch *index* key)))
     286               #f))
     287
     288         (lambda (key) ; get
     289            (let* ((entry (parse-index-entry (gdbm-fetch *index* (make-index-key key))))
     290                   (type (car entry))
     291                   (index (cadr entry))
     292                   (position (caddr entry))
     293                   (length (cadddr entry))
     294                   (buffer (make-blob length))
     295                   (logpart (get-log index)))
     296               (set-file-position! logpart position seek/set)
     297               (file-read logpart length buffer)
     298               (blob->u8vector/shared buffer)))
     299         (lambda (key) ; link!
     300            (void))
     301         (lambda (key) ; unlink!
     302            (signal (make-property-condition 'exn 'message "Log archives do not support deletion")))
     303         (lambda (tag key) ; set-tag!
     304            (gdbm-store *tags* (make-index-tag tag) key))
     305         (lambda (tag) ; tag
     306            (if (gdbm-exists *tags* (make-index-tag tag))
     307               (gdbm-fetch *tags* (make-index-tag tag))
     308               #f))
     309         (lambda () ; all-tags
     310            (gdbm-fold *tags* (lambda (key value acc) (cons key acc)) '()))
     311         (lambda (tag) ; remove-tag!
     312            (gdbm-delete *tags* (make-index-tag tag)))
     313         (lambda (tag) ; lock-tag!
     314            ; (printf "FIXME: Implement lock-tag! in backend-fs.scm\n")
     315            #f)
     316         (lambda (tag) ; tag-locked?
     317            ; (printf "FIXME: Implement tag-locked? in backend-fs.scm\n")
     318            #f)
     319         (lambda (tag) ; unlock-tag!
     320            ; (printf "FIXME: Implement unlock-tag! in backend-fs.scm\n")
     321            #f)
     322         (lambda () ; close!
     323            (gdbm-close *index*)
     324            (gdbm-close *tags*)
     325            (file-close *log*)
     326            (hash-table-for-each *logfiles*
     327               (lambda (key value)
     328                  (file-close value)))))))
    223329     
    224330   
  • release/3/ugarit/trunk/test.scm

    r13103 r13116  
    2727(define be (backend-log "./tmp/be2/log" "./tmp/be2/index" "./tmp/be2/tags"))
    2828(printf "backend-log: ~A\n" (test-backend be))
     29((storage-close! be))
     30
     31(create-directory "./tmp/be2a")
     32(define be (backend-splitlog "./tmp/be2a" "./tmp/be2a" 1024))
     33(printf "backend-splitlog: ~A\n" (test-backend be))
    2934((storage-close! be))
    3035
     
    355360     (else #f)))
    356361   
    357    (printf "\tTest fold-archive-node\n")
    358    
    359    (printf "Root: \n") (pp (fold-archive-node archive '() (lambda (name dirent acc) (cons (cons name dirent) acc)) '()))
    360    (printf "Tag 'Test': \n") (pp (fold-archive-node archive (cons 'tag "Test") (lambda (name dirent acc) (cons (cons name dirent) acc))  '()))
    361    (printf "Root directory: \n") (pp (fold-archive-node archive dir-key (lambda (name dirent acc) (cons (cons name dirent) acc))  '()))
     362   ;(printf "\tTest fold-archive-node\n")
     363   ;
     364   ;(printf "Root: \n") (pp (fold-archive-node archive '() (lambda (name dirent acc) (cons (cons name dirent) acc)) '()))
     365   ;(printf "Tag 'Test': \n") (pp (fold-archive-node archive (cons 'tag "Test") (lambda (name dirent acc) (cons (cons name dirent) acc))  '()))
     366   ;(printf "Root directory: \n") (pp (fold-archive-node archive dir-key (lambda (name dirent acc) (cons (cons name dirent) acc))  '()))
    362367   
    363368   "This archive seems to work!")
     
    366371
    367372(define archive (open-archive '((storage fs "./tmp/be5")) #f #t))
    368 (printf "archive: ~A\n" (test-archive archive "./tmp/be5"))
     373(printf "archive on fs: ~A\n" (test-archive archive "./tmp/be5"))
    369374(archive-close! archive)
    370375
     
    372377
    373378(define archive (open-archive '((storage log "./tmp/be6/log" "./tmp/be6/index" "./tmp/be6/tags")) #f #t))
    374 (printf "archive: ~A\n" (test-archive archive "./tmp/be6"))
     379(printf "archive on log: ~A\n" (test-archive archive "./tmp/be6"))
    375380(archive-close! archive)
     381
     382(create-directory "./tmp/be7")
     383
     384(define archive (open-archive '((storage splitlog "./tmp/be7" "./tmp/be7" 10000)) #f #t))
     385(printf "archive on splitlog: ~A\n" (test-archive archive "./tmp/be7"))
     386(archive-close! archive)
     387
  • release/3/ugarit/trunk/ugarit-core.scm

    r13103 r13116  
    144144            (('storage 'log logpath indexpath tagspath) (set! *storage*
    145145               (backend-log logpath indexpath tagspath)))
     146            (('storage 'splitlog logdir metadir maxlen) (set! *storage*
     147               (backend-splitlog logdir metadir maxlen)))
    146148            (('storage 'debug 'fs path) (set! *storage*
    147149               (backend-debug (backend-fs path) "DEBUG")))
  • release/3/ugarit/trunk/ugarit.meta

    r13103 r13116  
    55 (license "BSD")
    66 (category data)
    7  (needs mismacros gdbm tiger-hash z3 lzma srfi-37)
     7 (needs miscmacros gdbm tiger-hash z3 lzma srfi-37)
    88 (author "Alaric Snell-Pym")
    99 (synopsis "A backup/archival system based on content-addressed storage"))
  • release/3/ugarit/trunk/ugarit.setup

    r13103 r13116  
    11(compile -s -O2 -d1 ugarit-core.scm)
    22(compile -c -O2 -d1 ugarit-core.scm -unit ugarit-core)
    3 (install-extension 'ugarit-core '("ugarit-core.so" "ugarit-core.o"))
     3(install-extension 'ugarit-core '("ugarit-core.so" "ugarit-core.o")
     4  '((version 0.3)
     5    (static "ugarit-core.o")
     6    (documentation "ugarit.html")))
    47
    58(compile ugarit.scm)
    6 (install-program 'ugarit "ugarit")
     9(install-program 'ugarit "ugarit"
     10  '((version 0.3)
     11    (documentation "ugarit.html")))
Note: See TracChangeset for help on using the changeset viewer.