Changeset 25565 in project

11/24/11 00:25:57 (9 years ago)
Alaric Snell-Pym

ugarit: tag locking, and strict enforcement of maximum file size in splitlog archives

7 edited


  • release/4/ugarit/trunk/README.txt

    r25555 r25565  
    827827## Backends
     829* Create ugarit-backend-protocol-2, and extend import-backend to
     830  support it. The differences are:
     832  * Extend the backend API to have all API calls return a possibly
     833    empty list of log messages before the actual result. When
     834    importing a backend, provide a logging callback which is passed
     835    these lists and feeds them into a logging mechanism which prints
     836    them and stores them in the archive object for later logging into
     837    the snapshot. The same logging interface can then be used for
     838    warnings from within ugarit-core itself as well.
     840  * Extend the backend API to have an initial list of log messages and
     841    a possible error or success for initialisation, inside the
     842    header. Make the command-line wrappers for backends use this to
     843    indicate startup failure.
    829845* Carefully document backend API for other backend authors: in
    830846  particular note behaviour in crash situations - we assume that after
    835851  (see v1.0.2).
    837 * Make splitlog see if writing the block will go over the log file
    838   size limit, and if so, start a new file - rather than testing AFTER
    839   writing, leading to a potential extra partial block beyond the
    840   limit. It'd be nice to make it a hard limit.
    842 * Implement lock-tag! etc. in backend-fs, as a precaution against two
    843   concurrent snapshots racing over updating the tag, where concurrent
    844   access to the archive is even possible.
    846853* Lock the archive for writing in backend-splitlog, so that two
    847854  snapshots to the same archive don't collide. Do we lock per `put!`
    857864  to find (complete) blocks that did not get flushed to the metadata.
    859 * Make `lock-tag!` in backend-splitlog actually block until the tag is
    860   not already locked! With a timeout and an apologetic error message
    861   if it takes too long.
     866* Make `lock-tag!` fail if the tag is already locked. Make the archive
     867  block and retry a few times in that case.
    863869* Extend the backend protocol with a special "admin" command that
    970976  quick summary of the bytes/blocks stored/skipped stats.
    972 * Log all WARNINGs produced during a snapshot job, and attach them to
    973   the snapshot object as a text file.
    975978* Clarify what characters are legal in tag names sent to backends, and
    976979  what are legal in human-supplied tag names, and check that
    10801083  between archives, perhaps to change to a better backend.
     1085* Optional progress reporting callback from within store-file! and
     1086  store-directory!, called on each block within a file or on each
     1087  filesystem object, respectively.
     1089* Add a procedure to resolve a path within the archive node tree from
     1090  any root node. Pass in the path as a list of strings, with the
     1091  symbols `.` and `..` being usable as meta-characters to do nothing
     1092  or to go up a level. Write a utility procedure to parse a string
     1093  into such a form.
    10821095## Front-end
     1097* Install progress reporting callbacks to report progress to user;
     1098  option for quiet (no reporting), normal (reporting if >60s have
     1099  passed since last time), or verbose (report every file), or very
     1100  verbose (report every file and block).
    10841102* Add a command to force removing a tag lock.
    10861104* Add a command to list all the tags (with a * next to locked tags)
     1106* Add a command to list the contents of any directory in the archive
     1107  node tree
    10881109* Better error messages
    11321153  and restore the corpus several times over with each hash,
    11331154  compression, and encryption option.
     1156* Testing crashes. See about writing a test backend binary that either
     1157  raises an error or just kills the process directly after N
     1158  operations, and sit in a loop running it with increasing N. Take N
     1159  from an environment variable to make it easier to automate this.
     1161* Extract the debugging backend from backend-devtools into a proper
     1162  backend binary that takes a path to a log file and a backend command
     1163  line to wrap.
    11351165# Acknowledgements
    12191249  when tagging a snapshot) so that we ensure the blocks we point at
    12201250  are flushed before committing references to them in the
    1221   `backend-cache` or file caches, or into tags, to ensure crash safety.
     1251  `backend-cache` or file caches, or into tags, to ensure crash
     1252  safety. BUGFIX: Made the splitlog backend never exceed the file size
     1253  limit (except when passed blocks that, plus a header, are larger
     1254  than it), rather than letting a partial block hang over the
     1255  'end'. BUGFIX: Fixed tag locking, which was broken all over the
     1256  place. Concurrent snapshots to the same tag should now block for one
     1257  another, although why you'd want to *do* that is questionable.
    12231259* 1.0.1: Consistency check on read blocks by default. Removed warning
  • release/4/ugarit/trunk/backend-cache.scm

    r25555 r25565  
    9494         (flush!))
    9595      (lambda (tag) ; lock-tag!
    96          ((storage-lock-tag! be) tag)
    97          ((storage-flush! be))
    98          (flush!))
     96         (let ((result ((storage-lock-tag! be) tag)))
     97           ((storage-flush! be))
     98           (flush!)
     99           result))
    99100      (lambda (tag) ; tag-locked?
    100101         ((storage-tag-locked? be) tag))
  • release/4/ugarit/trunk/backend-devtools.scm

    r25555 r25565  
    120120            ((storage-remove-tag! be) tag)))
    121121      (lambda (tag) ; lock-tag!
    122          (begin
    123             (printf "~A: (lock-tag! ~A)\n" name tag)
    124             ((storage-lock-tag! be) tag)))
     122        (let ((result ((storage-lock-tag! be) tag)))
     123          (begin
     124            (printf "~A: (lock-tag! ~A) = ~A\n" name tag result)
     125            result)))
    125126      (lambda (tag) ; tag-locked?
    126127         (let ((result ((storage-tag-locked? be) tag)))
  • release/4/ugarit/trunk/backend-fs.scm

    r25555 r25565  
    4848   (define (make-tag-name tag)
    4949      (string-append base "/" tag ".tag"))
     51   (define (make-tag-lock-name tag)
     52      (string-append base "/" tag ".tag-lock"))
    5154   (if (not (directory? base))
    126129         (if (file-read-access? (make-tag-name tag))
    127130            (with-input-from-file (make-tag-name tag)
    128                (lambda () (read)))
     131               (lambda () (let ((key (read)))
     132                            (if (eof-object? key)
     133                                #f ; Treat empty file as no tag
     134                                key))))
    129135            #f))
    130136      (lambda () ; all-tags
    137143      (lambda (tag) ; remove-tag!
    138144         (if (file-write-access? (make-tag-name tag))
    139             (delete-file (make-tag-name tag))
     145            (begin
     146              (delete-file (make-tag-name tag))
     147              (when (file-exists? (make-tag-lock-name tag))
     148                    (delete-file (make-tag-lock-name tag))))
    140149            #f))
    141150      (lambda (tag) ; lock-tag!
    142          ; (printf "FIXME: Implement lock-tag! in backend-fs.scm\n")
    143          #f)
     151        ; Ensure tag file exists first, as an empty file if necessary
     152        (file-close (file-open (make-tag-name tag) (+ open/wronly open/append open/creat)))
     153        (condition-case
     154         (begin
     155           (file-link (make-tag-name tag) (make-tag-lock-name tag))
     156           #t)
     157         ((exn i/o file)
     158          #f)))  ; If we can't create it for any reason, we haven't got the lock; it'd be nicer to check errno = EEXIST, though, and raise an exception for other errors.
    144159      (lambda (tag) ; tag-locked?
    145          ; (printf "FIXME: Implement tag-locked? in backend-fs.scm\n")
    146          #f)
     160        (not (not (file-exists? (make-tag-lock-name tag)))))
    147161      (lambda (tag) ; unlock-tag!
    148          ; (printf "FIXME: Implement unlock-tag! in backend-fs.scm\n")
    149          #f)
     162        (delete-file (make-tag-lock-name tag))
     163        (void))
    150164      (lambda () ; close!
    151165         (void))))
    248262                         (let ((td (query fetch get-tag-query tag)))
    249263                           (if (pair? td)
    250                                (car td)
     264                               (if (null? (car td)) ; treat NULL as no tag
     265                                   #f
     266                                   (car td))
    251267                               #f))))
    259275                           (if (pair? td)
    260276                               (car td)
    261                                #f))))
     277                               (begin ; Tag does not exist, create it on demand
     278                                 (set-tag! tag '()) ; insert NULL tag record
     279                                 0)))))
    263281         (get-tags (lambda ()
    277295           (let ((header (sprintf "(block ~S ~S ~S)" key type (u8vector-length data)))
    278296                 (posn (file-position *log*)))
    279              (if (> posn max-logpart-size)
     297             (if (and (not (zero? posn)) (> (+ (u8vector-length data) (string-length header) posn) max-logpart-size))
    280298                 (begin
    281299                   (file-close *log*)
    331349           (void))
    332350         (lambda (tag) ; lock-tag!
    333            (set-tag-lock! tag 1)
    334            (void))
     351           (flush!)
     352           (let ((existing-lock? (not (zero? (get-tag-lock tag)))))
     353             (if existing-lock?
     354                 (begin
     355                   #f)
     356                 (begin
     357                   (set-tag-lock! tag 1)
     358                   (flush!)
     359                   #t))))
    335360         (lambda (tag) ; tag-locked?
    336361           (if (zero? (get-tag-lock tag))
    338363               #t))
    339364         (lambda (tag) ; unlock-tag!
    340            (set-tag-lock! tag 0))
     365           (set-tag-lock! tag 0)
     366           (flush!))
    341367         (lambda () ; close!
    342368           (flush!)
  • release/4/ugarit/trunk/test/run.scm

    r25555 r25565  
    4949         (test-assert "Unlinked block is gone" (not ((storage-exists? w) "TEST")))))
    5050   (test "Set a tag" (void) ((storage-set-tag! w) "TEST" "TEST123"))
     51   (test "Tag is not locked" #f ((storage-tag-locked? w) "TEST"))
     52   (test "Lock a tag" #t ((storage-lock-tag! w) "TEST"))
     53   (test "Tag is now locked" #t ((storage-tag-locked? w) "TEST"))
     54   (test "Lock a tag again" #f ((storage-lock-tag! w) "TEST"))
     55   (test "Tag is still locked" #t ((storage-tag-locked? w) "TEST"))
     56   (test "Unlock a tag" (void) ((storage-unlock-tag! w) "TEST"))
     57   (test "Tag is no longer locked" #f ((storage-tag-locked? w) "TEST"))
    5158   (test "Tag reads back" "TEST123" ((storage-tag w) "TEST"))
    5259   (test "Tag list works" (list "TEST") ((storage-all-tags w)))
    135142                     (test-assert "Unlinked data is gone" (not (archive-exists? a test-key)))))
    136143               (test "Tag setting" (void) (archive-set-tag! a "TEST" test-key))
     145               (test "Tag is not locked" #f (archive-tag-locked? a "TEST"))
     146               (test "Lock a tag" #t (archive-lock-tag! a "TEST"))
     147               (test "Tag is now locked" #t (archive-tag-locked? a "TEST"))
     148               (test-error "Lock a tag again" (archive-lock-tag! a "TEST"))
     149               (test "Tag is still locked" #t (archive-tag-locked? a "TEST"))
     150               (test "Unlock a tag" (void) (archive-unlock-tag! a "TEST"))
     151               (test "Tag is no longer locked" #f (archive-tag-locked? a "TEST"))
    137153               (test "Tag reading" test-key (archive-tag a "TEST"))
    138154               (test "Tag listing" (list "TEST") (archive-all-tags a))
    473489                                     (tag-snapshot! a "Test" dir2-key dir2-reused? (list)))
     491                 (test-define-values "Read the tag back" (tag2) (archive-tag a "Test"))
    475492                 (test-define-values "Walk the history with fold-history" (result)
    476                                      (fold-history a (archive-tag a "Test")
     493                                     (fold-history a tag2
    477494                                                   (lambda (snapshot-key snapshot acc)
    478495                                                     (cons snapshot acc))
  • release/4/ugarit/trunk/ugarit-backend.scm

    r25555 r25565  
    4747  all-tags ; Procedure: (all-tags) - returns a list of all existing tag names
    4848  remove-tag! ; Procedure: (remove-tag! name) - removes the named tag
    49   lock-tag! ; Procedure: (lock-tag! name) - locks the named tag, or blocks if already locked
    50   tag-locked? ; Procedure: (tag-locked? name) - returns the locker identity string if the tag is locked, #f otherwise
     49  lock-tag! ; Procedure: (lock-tag! name) - locks the named tag, returning #t if all went well, or #f if it can't be locked.
     50  tag-locked? ; Procedure: (tag-locked? name) - returns #t if the tag is locked, #f otherwise
    5151  unlock-tag! ; Procedure: (unlock-tag! name) - unlocks the named tag
    5252  close!)  ; Procedure: (close!) - closes the storage engine
    163163           (('lock-tag! name)
    164164            (with-error-reporting
    165              ((storage-lock-tag! storage) name)
    166              (write #t))
     165             (let  ((result ((storage-lock-tag! storage) name)))
     166               (write result)))
    167167            (loop))
    289289              (if debug (printf "~a: lock-tag!" command-line))
    290290              (write `(lock-tag! ,name) commands)
    291               (read-response responses)
    292               (void))
     291              (read-response responses))
    294293            (lambda (name)              ; tag-locked?
  • release/4/ugarit/trunk/ugarit-core.scm

    r25555 r25565  
    411411  (if (not (archive-writable? archive))
    412412      (signal (make-property-condition 'exn 'location 'archive-lock-tag! 'message "This isn't a writable archive")))
    413   ((storage-lock-tag! (archive-storage archive)) tag))
     413  (let loop ((tries-left 10))
     414    (if (zero? tries-left)
     415        (signal (make-property-condition 'exn 'location 'archive-lock-tag! 'message (sprintf "We timed out attempting to lock the tag '~A'" tag)))
     416        (let ((result ((storage-lock-tag! (archive-storage archive)) tag)))
     417          (if result
     418              result                       ; Lock got!
     419              (begin
     420                (thread-sleep! 1)
     421                (loop (- tries-left 1))))))))
    415423(define (archive-tag-locked? archive tag)
    844852       (for-each (lambda (filename)
    845853                   (handle-exceptions exn
    846                                       (printf "ERROR: Could not store ~a into the archive, skipping it...\n" (make-pathname path filename))
     854                                      (printf "ERROR: Could not store ~a into the archive (~a), skipping it...\n" (make-pathname path filename) ((condition-property-accessor 'exn 'message "Unknown error") exn))
    847855                                      (let* ((file-path (make-pathname path filename))
    848856                                             (stats (file-stat file-path #t))
    10721080(define (tag-snapshot! archive tag contents-key contents-reused? snapshot-properties)
    10731081  (check-archive-writable archive)
    1074   (archive-lock-tag! archive tag)
     1082  (archive-lock-tag! archive tag) ;; Lock BEFORE reading previous state of the tag, to avoid races.
    10751083  (let* ((previous (archive-tag archive tag))
    10761084         (stats (list
    10911099          (list ; We do not list the previous snapshot - since we are about to overwrite the tag that points to it, which would be a decrement.
    10921100           (cons contents-key contents-reused?))))
    1093     (if previous
    1094         (begin
    1095           (set! snapshot (cons
    1096                           (cons 'previous previous)
    1097                           snapshot))))
     1101    (when previous
     1102          (set! snapshot (cons
     1103                          (cons 'previous previous)
     1104                          snapshot)))
    10981105    (let-values (((snapshot-key snapshot-reused?)
    10991106                  (store-sexpr! archive snapshot 'snapshot keys)))
    11011108      (archive-set-tag! archive tag snapshot-key) ; Therefore, we can be confident in saving it in a tag.
    11021109      (archive-unlock-tag! archive tag)
     1110      (when snapshot-reused? ; Rare, but possible; fork a tag then snapshot the same FS state to both at the same second.
     1111            (archive-link! archive snapshot-key))
    11031112      snapshot-key)))
Note: See TracChangeset for help on using the changeset viewer.