administration

private/store.rkt

@@ -0,0 +1,131 @@
+#lang racket
+
+(require keystore
+         racket/serialize)
+
+(provide store-ref
+         store-set!
+         store-open
+         store-close
+         store-new
+         store-config!
+         store-exists?
+         store-remove!
+         store-keys
+         store-for-each
+         store-count
+         store-transaction
+         store-begin
+         store-commit
+         )
+
+(define store-kind 'hash)
+
+(define (store-config! #:kind [kind 'hash])
+  (if (not (or (eq? kind 'hash) (eq? kind 'keystore)))
+      (error "kind needs to be 'hash or 'keystore")
+      (set! store-kind kind)))
+
+(define (store-new file)
+  (if (eq? store-kind 'hash)
+      (let ((h (make-hash)))
+        (hash-set! h 'store-file file)
+        (list 'hash h))
+      (store-open file))
+  )
+
+(define (store-open file)
+  (if (eq? store-kind 'hash)
+      (if (file-exists? file)
+          (deserialize (file->value file))
+          (store-new file))
+      (list 'keystore (ks-open file))))
+
+(define (store-close st)
+  (if (eq? (car st) 'hash)
+      (let ((file (hash-ref (cadr st) 'store-file)))
+        (write-to-file
+         (serialize st) file #:exists 'replace))
+      (ks-close (cadr st))))
+
+(define (store-ref st key . val)
+  (if (eq? (car st) 'hash)
+      (if (null? val)
+          (hash-ref (cadr st) key)
+          (hash-ref (cadr st) key (car val)))
+      (let ((v (if (null? val)
+                   (ks-get (cadr st) key)
+                   (ks-get (cadr st) key (car val)))))
+        (if (eq? v 'ks-nil)
+            (error "No such key in storage")
+            v))
+      )
+  )
+
+(define (store-set! st key val)
+  (if (eq? (car st) 'hash)
+      (hash-set! (cadr st) key val)
+      (ks-set! (cadr st) key val)))
+
+(define (store-remove! st key)
+  (if (eq? (car st) 'hash)
+      (hash-remove! (cadr st) key)
+      (ks-drop! (cadr st) key)))
+
+(define (store-exists? st key)
+  (if (eq? (car st) 'hash)
+      (hash-has-key? (cadr st) key)
+      (ks-exists? (cadr st) key)))
+
+(define (store-keys st)
+  (if (eq? (car st) 'hash)
+      (filter (λ (k)
+                (not (eq? k 'store-file)))
+              (hash-keys (cadr st)))
+      (ks-keys (cadr st))))
+
+(define (store-count st)
+  (if (eq? (car st) 'hash)
+      (hash-count (cadr st))
+      (ks-key-count (cadr st))))
+
+(define (store-for-each st f)
+  (if (eq? (car st) 'hash)
+      (hash-for-each (cadr st)
+                     (λ (k v)
+                       (unless (eq? k 'store-file)
+                         (f k v))))
+      (let* ((ks (cadr st))
+             (keys (ks-keys ks)))
+        (for-each (λ (k)
+                    (let ((v (ks-get ks k)))
+                      (f k v)))
+                  keys))
+      )
+  )
+
+(define-syntax store-transaction
+  (syntax-rules ()
+    ((_ st b1 ...)
+     (if (eq? (car st) 'hash)
+         (begin b1 ...)
+         (ks-transaction (cadr st) b1 ...)))))
+
+(define (store-begin st)
+  (when (eq? (car st) 'keystore)
+    (ks-begin-transaction (cadr st)))
+  #t)
+
+(define (store-commit st)
+  (when (eq? (car st) 'keystore)
+    (ks-end-transaction (cadr st)))
+  #t)
+
+
+         
+
+
+
+
+
+