Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Online storage for test results, implemented in the new module test-g…

…rid-storage (based on another new module sptm - shared persistent transactional memory).
  • Loading branch information...
commit e468d4b4ebc40addc269840d635c0d6f369e3bd7 1 parent f740af8
@avodonosov avodonosov authored
View
74 data/data.lisp
@@ -4,7 +4,9 @@
(defpackage #:test-grid-data
(:use :cl)
- (:export #:read-db))
+ (:export
+ #:read-db
+ #:add-test-run))
(in-package #:test-grid-data)
@@ -16,9 +18,15 @@
(defvar *standard-db-file*
(merge-pathnames #P"../../cl-test-grid-results/db.lisp" (src-dir)))
+;;; DB operations
+
(defun add-run (run-info &optional (db *db*))
+ "Deprecated. Modifies DB destructively."
(push run-info (getf db :runs)))
+(defun new-db ()
+ (list :version 4 :runs nil))
+
(defun print-list-elements (destination list separator elem-printer)
(let ((maybe-separator ""))
(dolist (elem list)
@@ -26,6 +34,51 @@
(funcall elem-printer elem)
(setf maybe-separator separator))))
+(defun updated-plist (plist prop new-value)
+ (let ((new (copy-list plist)))
+ (setf (getf new prop) new-value)
+ new))
+
+(assert (= 2 (getf (updated-plist '(:a 1 :b 1) :a 2)
+ :a)))
+
+(defun add-test-run (db test-run)
+ ;; If DB is NIL, create new DB automatically
+ ;; it is convenient because allows to execute
+ ;; add-test-run transactions on test-grid-storage
+ ;; without checking, if DB was already initialized.
+ (let ((db (or db (new-db))))
+ (updated-plist db :runs (cons test-run (getf db :runs)))))
+
+(defun test-run-matcher (descr-key-val-plist)
+ (let ((key-val-alist (alexandria:plist-alist descr-key-val-plist)))
+ (lambda (test-run)
+ (let ((descr (test-grid-data::run-descr test-run)))
+ (every (lambda (key-val-cons)
+ (equal (getf descr (car key-val-cons))
+ (cdr key-val-cons)))
+ key-val-alist)))))
+
+(defun remove-test-runs (db &rest descr-key-val-plist)
+ (updated-plist db :runs (remove-if (test-run-matcher descr-key-val-plist)
+ (getf db :runs))))
+
+(defun remove-lib-result (db
+ test-run-descr-key-val-plist
+ libname)
+ (let* ((matcher (test-run-matcher test-run-descr-key-val-plist))
+ (new-test-runs (mapcar (lambda (test-run)
+ (if (funcall matcher test-run)
+ (updated-plist test-run :results
+ (remove-if (lambda (lib-result)
+ (eq libname (getf lib-result :libname)))
+ (getf test-run :results)))
+ test-run))
+ (getf db :runs))))
+ (updated-plist db :runs new-test-runs)))
+
+;;; DB printing
+
(defun print-list (destination list separator elem-printer)
(format destination "(")
(print-list-elements destination list separator elem-printer)
@@ -108,20 +161,23 @@
(format out ")")))
(format out "))"))
+(defun print-db (out db &optional (indent 0))
+ (format out "(:version ~a~%" (getf db :version))
+ (format out "~v,0t :runs (" indent)
+ (print-list-elements out
+ (getf db :runs)
+ (format nil "~%~v,0t" (+ indent 8))
+ #'(lambda (test-run)
+ (print-test-run out test-run (+ indent 8))))
+ (format out "))"))
+
(defun save-db (&optional (db *db*) (stream-or-path *standard-db-file*))
(with-open-file (out stream-or-path
:direction :output
:element-type 'character ;'(unsigned-byte 8) + flexi-stream
:if-exists :supersede
:if-does-not-exist :create)
- (format out "(:version ~a~%" (getf db :version))
- (format out " :runs (")
- (print-list-elements out
- (getf db :runs)
- "~%~8t"
- #'(lambda (test-run)
- (print-test-run out test-run 8)))
- (format out "))")))
+ (print-db out db)))
(defun read-db (&optional (stream-or-path *standard-db-file*))
(with-open-file (in stream-or-path
View
23 sptm.asd
@@ -0,0 +1,23 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; -*-
+;;; Copyright (C) 2011 Anton Vodonosov (avodonosov@yandex.ru)
+;;; See LICENSE for details.
+
+(asdf:defsystem #:sptm
+ :version "0.1.0"
+ :serial t
+ :depends-on (#:zaws
+ #:zaws-xml
+ #:zs3
+ #:gzip-stream
+ #:babel
+ #:alexandria
+ #:test-grid-utils)
+ :components
+ ((:module "sptm"
+ :serial t
+ :components
+ ((:file "package")
+ (:file "versioned-data")
+ (:file "amazon-simple-db")
+ (:file "aws-transaction-log")
+ (:file "replica")))))
View
86 sptm/amazon-simple-db.lisp
@@ -0,0 +1,86 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; -*-
+;;; Copyright (C) 2011 Anton Vodonosov (avodonosov@yandex.ru)
+;;; See LICENSE for details.
+
+(in-package #:sptm)
+
+(defclass simpledb-request (zaws:common-query-request zaws:query-auth-v2)
+ ((duration-seconds
+ :initarg :duration-seconds
+ :accessor duration-seconds))
+ (:default-initargs
+ :host "sdb.amazonaws.com"
+ :api-version "2009-04-15"))
+
+;;; signalling errors of REST responses
+;;; returned by Amazon Web Services
+
+(defun report-aws-error (response)
+ (error "Amazon Web Service returned error. HTTP status: ~A ~A.~%Body: ~A"
+ (zaws:status-code response)
+ (zaws:reason-phrase response)
+ (zaws:content-string response)))
+
+;;; select function, returns list of items
+;;; each item has ITEM-NAME and
+;;; attributes. Attribute values
+;;; may be retrieved using ITEM-ATTR.
+
+(zaws-xml:defbinder select-response
+ ("SelectResponse"
+ ("SelectResult"
+ (sequence :items
+ ("Item" ("Name" (zaws-xml:bind :name))
+ (zaws-xml:optional (sequence :attributes
+ ("Attribute" ("Name" (zaws-xml:bind :name))
+ ("Value" (zaws-xml:bind :value)))))))
+ (zaws-xml:optional ("NextToken" (zaws-xml:bind :next-token))))
+ zaws-xml:skip-rest))
+
+(defun item-name (item)
+ (zaws-xml:bvalue :name item))
+
+(defun item-attr (item attribute-name)
+ (zaws-xml:bvalue :value
+ (or (find attribute-name
+ (zaws-xml:bvalue :attributes item)
+ :key (alexandria:curry #'zaws-xml:bvalue :name)
+ :test #'string=)
+ (error "Attribute ~S not found: ~S" attribute-name item))))
+
+(defun submit-select (query &key ((:credentials zaws:*credentials*) zaws:*credentials*) next-token)
+ "Returns the response XML parsed by zaws-xml into bindings according to the select-response binder
+defined above."
+ (let ((response (zaws:submit (make-instance 'simpledb-request
+ :action "Select"
+ :action-parameters (append
+ (zaws:make-parameters "ConsistentRead" "true"
+ "SelectExpression" query)
+ (when next-token
+ (list (cons "NextToken" next-token))))))))
+ (if (= 200 (zaws:status-code response))
+ (zaws-xml:xml-bind 'select-response
+ (zaws:content-string response))
+ (report-aws-error response))))
+
+(defun select (query &key ((:credentials zaws:*credentials*) zaws:*credentials*))
+ (zaws-xml:bvalue :items (submit-select query)))
+
+(defun select-all (query &key ((:credentials zaws:*credentials*) zaws:*credentials*))
+ (let ((next-token nil)
+ (results '()))
+ (loop (let ((bindings (submit-select query :next-token next-token)))
+ (setf results (nconc (zaws-xml:bvalue :items bindings) results)
+ next-token (zaws-xml:bvalue :next-token bindings))
+ (when (null next-token)
+ (return results))))))
+
+(defun delete-item (domain item-name &key ((:credentials zaws:*credentials*) zaws:*credentials*))
+ (let* ((request (make-instance 'simpledb-request
+ :action "DeleteAttributes"
+ :action-parameters (zaws:make-parameters "DomainName" domain
+ "ItemName" item-name)))
+ (response (zaws:submit request)))
+ (unless (= 200 (zaws:status-code response))
+ (report-aws-error response))))
+
View
275 sptm/aws-transaction-log.lisp
@@ -0,0 +1,275 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; -*-
+;;; Copyright (C) 2011 Anton Vodonosov (avodonosov@yandex.ru)
+;;; See LICENSE for details.
+
+(in-package #:sptm)
+
+(defclass aws-transaction-log ()
+ ((name :type string
+ :accessor name
+ :initarg :name
+ :initform (error ":name is required"))
+ (credentials :type cons
+ :accessor credentials
+ :initarg :credentials
+ :initform (error ":credentials are required"))
+ (s3-bucket :type string
+ :accessor s3-bucket
+ :initarg :s3-bucket
+ :initform (error ":s3-bucket is required"))
+ (simpledb-domain :type string
+ :accessor simpledb-domain
+ :initarg :simpledb-domain
+ :initform (error ":simpledb-domain is required"))))
+
+(zaws-xml:defbinder error-response
+ ("Response"
+ ("Errors"
+ (sequence :errors
+ ("Error" ("Code" (zaws-xml:bind :code))
+ ("Message" (zaws-xml:bind :message))
+ zaws-xml:skip-rest)))
+ zaws-xml:skip-rest))
+
+(defun conditional-check-failed-p (put-attribute-response)
+ (and (= 409 (zaws:status-code put-attribute-response))
+ (member "ConditionalCheckFailed"
+ (zaws-xml:bvalue :errors
+ (zaws-xml:xml-bind 'error-response
+ (zaws:content-string put-attribute-response)))
+ :key (alexandria:curry #'zaws-xml:bvalue :code)
+ :test #'string=)))
+
+(defun version-str (version-number)
+ (format nil "~9,'0D" version-number))
+
+(defun max-version-str ()
+ "999999999")
+
+(defun parse-version-number (simpledb-item-name)
+ (let* ((name-start (1+ (search "-" simpledb-item-name)))
+ (name-end (search "-" simpledb-item-name :start2 name-start)))
+ (parse-integer simpledb-item-name
+ :start name-start
+ :end name-end)))
+
+(assert (= 132 (parse-version-number "test-000000132-tx")))
+(assert (= 132 (parse-version-number "test-000000132-snapshot")))
+
+(defgeneric serialize-to-string (log object)
+ (:method ((log aws-transaction-log) object)
+ (with-standard-io-syntax
+ (with-output-to-string (s)
+ (prin1 object s)))))
+
+(defgeneric deserialize-from-string (log string)
+ (:method ((log aws-transaction-log) string)
+ (with-input-from-string (s string)
+ (test-grid-utils::safe-read s))))
+
+(defun gzip-string (str)
+ "Returns byte vector"
+ (gzip-stream:gzip-sequence (babel:string-to-octets str)))
+
+(defun gunzip-string (byte-vector)
+ (babel:octets-to-string (gzip-stream:gunzip-sequence byte-vector)))
+
+(assert (string= "abc" (gunzip-string (gzip-string "abc"))))
+
+(defun short-timestamp (&optional (time (get-universal-time)))
+ "Returns a short timestamp string in GMT time."
+ (multiple-value-bind (sec min hour day month year day-of-week)
+ (decode-universal-time time 0)
+ (declare (ignore day-of-week))
+ (format nil "~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D~2,'0D"
+ year month day hour min sec)))
+
+(defvar *suffix-random-state* nil)
+
+(defun random-suffix ()
+ (when (null *suffix-random-state*)
+ (setf *suffix-random-state* (make-random-state t)))
+ (format nil "~36,3,'0r" (random #.(expt 36 3) *suffix-random-state*)))
+
+(defgeneric unique-s3-object-name (log)
+ (:method ((log aws-transaction-log))
+ (format nil "~A-~A.~A" (name log) (short-timestamp) (random-suffix))))
+
+(defmethod persist-funcall ((log aws-transaction-log) func-symbol args-without-data-arg)
+ (let ((value (gzip-string (serialize-to-string log (list func-symbol args-without-data-arg))))
+ (name (unique-s3-object-name log)))
+ (zs3:put-vector value (s3-bucket log) name
+ :access-policy :private
+ :content-type "text/plain"
+ :content-encoding "gzip"
+ :credentials (credentials log))
+ name))
+
+(defmethod commit-version ((log aws-transaction-log) version-number s3-object-name)
+ (let* ((zaws:*credentials* (credentials log))
+ (request (make-instance 'simpledb-request
+ :action "PutAttributes"
+ :action-parameters (zaws:make-parameters "DomainName" (simpledb-domain log)
+ "ItemName" (format nil "~A-~A-tx"
+ (name log)
+ (version-str version-number))
+ "Attribute.1.Name" "s3objectname"
+ "Attribute.1.Value" s3-object-name
+ "Expected.1.Exists" "false"
+ "Expected.1.Name" "s3objectname")))
+ (response (zaws:submit request)))
+ (cond
+ ((conditional-check-failed-p response) nil)
+ ((= 200 (zaws:status-code response)))
+ (t (report-aws-error response)))))
+
+(defclass aws-transaction ()
+ ((transaction-log :type aws-transaction-log
+ :accessor transaction-log
+ :initarg :transaction-log
+ :initform (error ":transaction-log is required"))
+ (version :type fixnum
+ :accessor version
+ :initarg :version
+ :initform (error ":version is required"))
+ (s3-object-name :type string
+ :accessor s3-object-name
+ :initarg :s3-object-name
+ :initform (error ":s3-object-name is required"))
+ (s3-object-content :type t
+ :initform nil)))
+
+(defmethod print-object ((tx aws-transaction) stream)
+ (print-unreadable-object (tx stream :type t :identity t)
+ (format stream "~A ~S ..." (version tx) (func tx))))
+
+(defmethod func ((transaction aws-transaction))
+ (first (s3-object-content transaction)))
+
+(defmethod args ((transaction aws-transaction) data)
+ (cons data (second (s3-object-content transaction))))
+
+(defun s3-object-content (aws-transaction)
+ (when (null (slot-value aws-transaction 's3-object-content))
+ (setf (slot-value aws-transaction 's3-object-content)
+ (let ((log (transaction-log aws-transaction)))
+ (deserialize-from-string log
+ (gunzip-string (zs3:get-vector (s3-bucket log)
+ (s3-object-name aws-transaction)
+ :credentials (credentials log)))))))
+ (slot-value aws-transaction 's3-object-content))
+
+(defmethod list-transactions ((log aws-transaction-log) after-version)
+ (flet ((make-transaction (item)
+ (make-instance 'aws-transaction
+ :transaction-log log
+ :version (parse-version-number (item-name item))
+ :s3-object-name (item-attr item "s3objectname"))))
+ (mapcar #'make-transaction
+ (select-all (format nil
+ "select * from cltestgrid where itemName() like '%-tx' and itemName() > '~A-~A-tx' and itemName() < '~A-~A-tx' order by itemName() limit 2500"
+ (name log)
+ (version-str after-version)
+ (name log)
+ (max-version-str))
+ :credentials (credentials log)))))
+
+(defun border-transaction-item (log max-or-min)
+ (first (select (format nil
+ "select * from cltestgrid where itemName() like '~A-%' and itemName() like '%-tx' order by itemName() ~A limit 1"
+ (name log)
+ (ecase max-or-min
+ (:max "desc")
+ (:min "asc")))
+ :credentials (credentials log))))
+
+(defun min-transaction-item (log)
+ (border-transaction-item log :min))
+
+(defun max-transaction-item (log)
+ (border-transaction-item log :max))
+
+(defmethod min-transaction-version ((log aws-transaction-log))
+ (let ((item (or (min-transaction-item log)
+ (error "min-transaction-version is invoked on emtpy log"))))
+ (parse-version-number (item-name item))))
+
+(defmethod max-transaction-version ((log aws-transaction-log))
+ (let ((item (or (max-transaction-item log)
+ (error "max-transaction-version is invoked on emtpy log"))))
+ (parse-version-number (item-name item))))
+
+(defmethod empty-p ((log aws-transaction-log))
+ (null (min-transaction-item log)))
+
+
+(defun last-snapshot-item (log)
+ (first (select (format nil
+ "select * from cltestgrid where itemName() like '~A-%' and itemName() like '%-snapshot' order by itemName() desc limit 1"
+ (name log))
+ :credentials (credentials log))))
+
+(defmethod snapshot-version ((log aws-transaction-log))
+ (let ((item (last-snapshot-item log)))
+ (if item
+ (parse-version-number (item-name item))
+ 0)))
+
+(defmethod get-snapshot ((log aws-transaction-log))
+ (let ((item (last-snapshot-item log)))
+ (if item
+ (make-instance 'versioned-data
+ :version (parse-version-number (item-name item))
+ :data (deserialize-from-string log
+ (gunzip-string (zs3:get-vector (s3-bucket log)
+ (item-attr item "s3objectname")
+ :credentials (credentials log)))))
+ (make-instance 'versioned-data))))
+
+(defmethod save-snapshot ((log aws-transaction-log) versioned-data)
+ (let* (;; simple DB item name according the same pattern as transaction item
+ ;; names: <log-name>-<version>-snapshot
+ (snapshot-db-name (format nil
+ "~A-~A-snapshot"
+ (name log)
+ (version-str (version versioned-data))))
+ ;; S3 object name as <log-name>-snaphot-<version>, so that all
+ ;; snapshots are grouped together and easy to find in AWS console
+ (snapshot-s3-name (format nil "~A-snapshot-~A"
+ (name log)
+ (version-str (version versioned-data)))))
+
+ (zs3:put-vector (gzip-string (serialize-to-string log (data versioned-data)))
+ (s3-bucket log)
+ snapshot-s3-name
+ :access-policy :private
+ :content-type "text/plain"
+ :content-encoding "gzip"
+ :credentials (credentials log))
+
+ (let* ((zaws:*credentials* (credentials log))
+ (request (make-instance 'simpledb-request
+ :action "PutAttributes"
+ :action-parameters (zaws:make-parameters "DomainName" (simpledb-domain log)
+ "ItemName" snapshot-db-name
+ "Attribute.1.Name" "s3objectname"
+ "Attribute.1.Value" snapshot-s3-name
+ "Attribute.1.Replace" "true")))
+ (response (zaws:submit request)))
+ (unless (= 200 (zaws:status-code response))
+ (report-aws-error response)))))
+
+(defun delete-records (log &key (from-version 0) (below-version nil))
+ (dolist (item (select-all (format nil
+ "select * from cltestgrid where itemName() >= '~A-~A' and itemName() < '~A-~A' order by itemName() limit 2500"
+ (name log)
+ (version-str from-version)
+ (name log)
+ (if below-version (version-str below-version) (max-version-str)))
+ :credentials (credentials log)))
+ (zs3:delete-object (s3-bucket log)
+ (item-attr item "s3objectname")
+ :credentials (credentials log))
+ (delete-item (simpledb-domain log)
+ (item-name item)
+ :credentials (credentials log))))
View
6 sptm/package.lisp
@@ -0,0 +1,6 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; -*-
+;;; Copyright (C) 2011 Anton Vodonosov (avodonosov@yandex.ru)
+;;; See LICENSE for details.
+
+(defpackage #:sptm
+ (:use :cl))
View
78 sptm/replica.lisp
@@ -0,0 +1,78 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; -*-
+;;; Copyright (C) 2011 Anton Vodonosov (avodonosov@yandex.ru)
+;;; See LICENSE for details.
+
+(in-package :sptm)
+
+(defclass replica ()
+ ((vdata
+ :type versioned-data
+ :accessor vdata
+ :initform (make-instance 'versioned-data))
+ (transaction-log
+ :accessor transaction-log
+ :initarg :transaction-log
+ :initform (error ":transaction-log is required"))
+ (transaction-checker
+ :type (or symbol function)
+ :accessor transaction-checker
+ :initarg :transaction-checker
+ :initform (constantly t))
+ (local-snapshot-file
+ :accessor local-snapshot-file
+ :initarg :local-snapshot-file
+ :initform (error ":local-snapshot-file is required"))))
+
+(defgeneric read-local-snapshot (replica))
+(defgeneric save-local-snapshot (replica))
+
+(defmethod data ((replica replica))
+ (data (vdata replica)))
+
+(defmethod version ((replica replica))
+ (version (vdata replica)))
+
+(defmethod read-local-snapshot ((replica replica))
+ (let ((plist (test-grid-utils::safe-read-file (local-snapshot-file replica))))
+ (setf (vdata replica)
+ (make-instance 'versioned-data
+ :version (getf plist :version)
+ :data (getf plist :data))))
+ replica)
+
+(defmethod save-local-snapshot ((replica replica))
+ (let ((versioned-data (vdata replica)))
+ (test-grid-utils::write-to-file (list :version (version versioned-data)
+ :data (data versioned-data))
+ (local-snapshot-file replica)))
+ replica)
+
+(defun sync (replica)
+ (when (and (zerop (version replica))
+ (probe-file (local-snapshot-file replica)))
+ (read-local-snapshot replica))
+ (let* ((cur-vdata (vdata replica))
+ (new-vdata (roll-forward cur-vdata
+ (transaction-log replica)
+ (transaction-checker replica))))
+ (when (not (eq new-vdata (vdata replica)))
+ (setf (vdata replica) new-vdata)
+ (save-local-snapshot replica)))
+ replica)
+
+;;; convenience replica-based wrappers around exec-transaction
+
+(defun repli-exec (replica func-symbol args)
+ (unless (funcall (transaction-checker replica) func-symbol)
+ (cerror "Continue, appying this forbidden function."
+ "You are trying to execute and record to the transaction log a function, forbidded by transaction-checker of this replica."))
+ (let ((new-vdata (exec-transaction (transaction-log replica)
+ (vdata replica)
+ func-symbol
+ args)))
+ (setf (vdata replica) new-vdata)))
+
+(defun repli-exec-save (replica func-symbol args)
+ (repli-exec replica func-symbol args)
+ (save-local-snapshot replica))
+
View
118 sptm/versioned-data.lisp
@@ -0,0 +1,118 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; -*-
+;;; Copyright (C) 2011 Anton Vodonosov (avodonosov@yandex.ru)
+;;; See LICENSE for details.
+
+(in-package #:sptm)
+
+(defclass versioned-data ()
+ ((version :type fixnum
+ :accessor version
+ :initform 0
+ :initarg :version)
+ (data :type t
+ :accessor data
+ :initform nil
+ :initarg :data)))
+
+(defmethod print-object ((vdata versioned-data) stream)
+ (print-unreadable-object (vdata stream :type t :identity t)
+ (format stream "~D ~S"
+ (version vdata)
+ (data vdata))))
+
+;;; transactions
+
+(defgeneric version (transaction))
+(defgeneric func (transaction))
+(defgeneric args (transaction cur-data))
+
+(defmethod apply-transaction ((d versioned-data) transaction)
+ (make-instance 'versioned-data
+ :data (apply (func transaction)
+ (args transaction (data d)))
+ :version (version transaction)))
+
+;;; transaction log
+
+(defgeneric empty-p (log)) ;; todo: rename to has-transactions-p
+(defgeneric min-transaction-version (log))
+(defgeneric max-transaction-version (log))
+(defgeneric list-transactions (log after-version))
+(defgeneric snapshot-version (log))
+(defgeneric get-snapshot (log))
+(defgeneric save-snapshot (log versioned-data))
+(defgeneric persist-funcall (log func-symbol args-without-data-arg))
+(defgeneric commit-version (log version-number presist-funcall-result)
+ (:documentation
+ "Returns true if the version is commited successfully,
+false if the version is not commited due to concurrency
+conflict (somebody else already commited such version).
+Signals error in case of problems."))
+
+;;; play transaction log
+
+(defmethod roll-forward (versioned-data log &optional (transaction-checker (constantly 't)))
+ (assert
+ ;; if there are transactions in the log,
+ ;; their db versions start not later
+ ;; than right after the db version of
+ ;; snapshot
+ (or (empty-p log)
+ (>= (snapshot-version log)
+ (1- (min-transaction-version log)))))
+
+ (if (empty-p log)
+ (if (> (snapshot-version log)
+ (version versioned-data))
+ (get-snapshot log)
+ versioned-data)
+ (let ((cur-vdata (if (< (version versioned-data)
+ (1- (min-transaction-version log)))
+ ;; Our versioned-data is so outdated, that transaction
+ ;; log doesn't have all the transactions necessary to roll forward.
+ (get-snapshot log)
+ versioned-data)))
+ (assert (>= (version cur-vdata) (1- (min-transaction-version log))))
+ (flet ((apply-transaction* (vdata transaction)
+ (unless (funcall transaction-checker (func transaction))
+ (error "The transaction ~A retrieved from transaction log specifies function ~S forbidden by the transaction checker"
+ transaction (func transaction)))
+ (apply-transaction vdata transaction)))
+ (reduce #'apply-transaction* (list-transactions log (version cur-vdata))
+ :initial-value cur-vdata)))))
+
+;;; perform new transactions
+
+(defmethod record-transaction (log
+ func-symbol
+ args-without-data-arg)
+ (let ((last-version (if (empty-p log)
+ 1
+ (max-transaction-version log)))
+ (funcall-name (persist-funcall log func-symbol args-without-data-arg)))
+ (loop for ver from (1+ last-version)
+ until (commit-version log ver funcall-name)
+ finally (return ver))))
+
+(defmethod exec-transaction (log vdata func-symbol args)
+ (let ((new-data (apply func-symbol (data vdata) args))
+ (fcall (persist-funcall log func-symbol args)))
+ (loop
+ (if (commit-version log (1+ (version vdata)) fcall)
+ (return (make-instance 'versioned-data
+ :version (1+ (version vdata))
+ :data new-data))
+ (setf vdata (roll-forward vdata log)
+ new-data (apply func-symbol (data vdata) args))))))
+
+;;; convinience
+
+(defun initial-value (db value)
+ "This function is expected to be often used
+in the first transaction, to initialize the persistent
+data to some data structure. Just returns the VALUE,
+so that after such transaction the persistent data
+is initialized to this VALUE."
+ (unless (null db)
+ (error "DB is already initialized to some value"))
+ value)
View
73 storage/storage.lisp
@@ -0,0 +1,73 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; -*-
+;;; Copyright (C) 2011 Anton Vodonosov (avodonosov@yandex.ru)
+;;; See LICENSE for details.
+
+(defpackage #:test-grid-storage
+ (:use :cl)
+ (:import-from #:sptm #:sync #:data #:version)
+ (:export
+ ;; replica creation
+ #:make-replica
+ ;; replica attributes
+ #:name
+ #:data
+ #:version
+ ;; replica operations
+ #:sync
+ ;; convenience method to record the most often used transaction
+ #:add-test-run))
+
+(in-package #:test-grid-storage)
+
+(defgeneric make-replica -snapshot-file)
+(defgeneric name (replica))
+
+(defclass replica (sptm::replica) ())
+
+;; Amazon Web Service credentials for cl-test-grid-user account
+;; in the form (<Access Key Id> <Secret Access Key>).
+;; This user is not the owner of our S3 bucket and SimpleDB domain,
+;; but has access to them (wich can be quickly revoked in case
+;; of any hooliganism)
+(defparameter *cl-test-grid-user-credentials*
+ '("AKIAJS4QAUS7CU5BK5MA" "wf4CbpVQHwuD9LkS+7Dby3exfc7PTv1upvZewIa0"))
+
+(defun make-transaction-log (name)
+ (make-instance 'sptm::aws-transaction-log
+ :name name
+ :simpledb-domain "cltestgrid"
+ :s3-bucket "cl-test-grid"
+ :credentials *cl-test-grid-user-credentials*))
+
+(defun transaction-allowed-p (func-symbol)
+ (member func-symbol '(sptm::initial-value test-grid-data:add-test-run)))
+
+(defmethod make-replica (name local-snapshot-file)
+ (make-instance 'replica
+ :transaction-log (make-transaction-log name)
+ :transaction-checker 'transaction-allowed-p
+ :local-snapshot-file local-snapshot-file))
+
+(defmethod name ((replica replica))
+ (sptm::name (sptm::transaction-log replica)))
+
+;; override the local snapshow serialization
+;; to pretty format the data
+(defmethod sptm::save-local-snapshot ((replica replica))
+ (let ((versioned-data (sptm::vdata replica)))
+ (with-open-file (out (sptm::local-snapshot-file replica)
+ :direction :output
+ :element-type 'character ;'(unsigned-byte 8) + flexi-stream
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (format out "(:version ~a~%" (sptm::version versioned-data))
+ (format out " :data ")
+ (test-grid-data::print-db out
+ (sptm::data versioned-data)
+ 7)
+ (format out ")")))
+ replica)
+
+(defun add-test-run (storage-name test-run)
+ (let ((log (make-transaction-log storage-name)))
+ (sptm::record-transaction log 'test-grid-data::add-test-run (list test-run))))
View
2  test-grid-data.asd
@@ -5,7 +5,7 @@
(asdf:defsystem #:test-grid-data
:version "0.3.1"
:serial t
- :depends-on (#:test-grid-utils)
+ :depends-on (#:test-grid-utils #:alexandria)
:components
((:module "data"
:serial t
View
13 test-grid-storage.asd
@@ -0,0 +1,13 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; -*-
+;;; Copyright (C) 2011 Anton Vodonosov (avodonosov@yandex.ru)
+;;; See LICENSE for details.
+
+(asdf:defsystem #:test-grid-storage
+ :version "1.0.1"
+ :serial t
+ :depends-on (#:test-grid-data
+ #:sptm)
+ :components ((:module "storage"
+ :serial t
+ :components
+ ((:file "storage")))))
Please sign in to comment.
Something went wrong with that request. Please try again.