Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

522 lines (455 sloc) 20.192 kb
#lang scheme/base
(require (file "util.scm")
(file "record.scm")
(file "settings.scm")
"log.scm")
(provide store-rec!
delete-rec!
add-child-and-save!
remove-child-and-save!
load-children
load-descendants
contains-child?
load-rec
record-id-stored?
refresh
rec-rec-prop
load-where
load-one-where
fresh-rec-from-data
only-rec-of-type
if-rec-of-type
is-descendant?
find-parent
find-ancestor
find-highest-ancestor
find-incoming-record
find-incoming-records
sort-recs-by
define-cache
define-type-cache
populate-caches
)
;;
;; Usage, e.g.:
;; (only-rec-of-type passed-in-rec-id location (item)
;; (rec-prop item 'title))
;;
(define-syntax only-rec-of-type
(syntax-rules ()
((_ rec-id type (rec-iden) body ...)
(let ((rec-iden (load-rec rec-id)))
(if (and rec-iden (rec-type-is? rec-iden 'type))
(begin body ...)
(e "Unauthorized access."))))))
(define-syntax if-rec-of-type
(syntax-rules ()
((_ rec-id type (rec-iden) then-clause else-clause)
(let ((rec-iden (and (record-id-stored? rec-id) (load-rec rec-id))))
(if (and rec-iden (rec-type-is? rec-iden 'type))
then-clause
else-clause)))))
(define (store-rec! r)
(cache-store r)
(write-record! r)
r)
;; if recur is #t, then look for child-props in the children too
(define (delete-rec! r
#:children-props-to-delete (child-props '())
#:recur (recur #f))
(define (delete-chillins item)
(for-each (lambda (child-prop)
(for-each (lambda (child-id)
(let ((child (load-rec child-id)))
(cache-delete child)
(delete-file (abs-path-to-record child-id))
(when recur (delete-chillins child))))
(rec-child-prop item child-prop)))
child-props))
(cache-delete r)
(delete-file (abs-path-to-record (rec-id r)))
(delete-chillins r))
;; pass #:ensure if you want to make sure that the record you are loading has particular
;; properties. A common use case is a security check so user can't url hack to load
;; arbitrary records: (load-rec some-id #:ensure '((type . blog-post))
;;
;; It is an error if the given record id doesn't exist.
;;
(define (load-rec id #:ensure (ensure '()))
(or (and-let* ((data (read-record-data id))
(result (rec-filter-where (list (make-rec data id)) ensure)))
(if (empty? result)
#f
(first result)))
(e "Record with id ~A does not exist in repository." id)))
(define (refresh rec)
(load-rec (rec-id rec)))
;; adds the given child to the parent and saves the parent (not the child).
;; if #:to-end is non-#f, then add the child to the end of the child list.
(define (add-child-and-save! parent prop child #:to-end (to-end #f))
(rec-add-child! parent prop child #:to-end to-end)
(store-rec! parent))
(define (remove-child-and-save! parent prop child)
(rec-remove-child! parent prop child)
(store-rec! parent))
(define (load-children parent prop)
(map load-rec (rec-child-prop parent prop)))
(define (load-descendants parent recursive-prop)
(let ((one-level (load-children parent recursive-prop)))
(append one-level (append-map (cut load-descendants <> recursive-prop) one-level))))
;; returns #f if nothing exists for the property.
(define (rec-rec-prop rec prop)
(aand (rec-prop rec prop) (load-rec it)))
(define (contains-child? parent prop putative-child)
(any (cute string=? <> (rec-id putative-child)) (rec-child-prop parent prop)))
;; if id is already provided then don't overwrite
(define (fresh-rec-from-data data
#:stamp-time (stamp-time #f)
#:id-length (id-length #f)
#:id (id #f))
(let* ((id (or (assoc-val 'id data)
(cond (id id)
(id-length (fresh-id #:id-length id-length))
(else (fresh-id)))))
(rec (make-rec data id)))
(when stamp-time (rec-set-prop! rec 'created-at (current-seconds)))
rec))
(define (fresh-id #:id-length (id-length 5))
(let ((try (random-key-string id-length)))
(if (file-exists? (abs-path-to-record try))
(fresh-id #:id-length id-length)
try)))
(define (ignore-filename? filename-path)
(let ((ignore-regexps
(list
;; subversion directories:
".svn"
;; emacs tmp files:
"~$")))
(and (any (lambda (re) (pregexp-match re filename-path)) ignore-regexps) #t)))
;;
;; load-all-recs
;;
;; #:type should be a symbol or a list of symbols
;;
;; this references the type caches for potential efficiency improvements.
;;
(define (load-all-recs #:type (type-or-types #f))
(or (and type-or-types
(if (list? type-or-types)
(let ((lookups (map type-cache-get-records type-or-types)))
(if (any not lookups)
#f
lookups))
(type-cache-get-records type-or-types)))
(filter-map (lambda (filename-path)
(let ((filename (path->string filename-path)))
(and (not (ignore-filename? filename))
(and-let* ((rec (load-rec filename)))
(cond ((not type-or-types) rec)
((symbol? type-or-types)
(and (rec-type-is? rec type-or-types) rec))
((list? type-or-types)
(and (memq (rec-prop rec 'type) type-or-types) rec))
(else (e "Can't restrict where type(s) is '~A'."
type-or-types)))))))
(directory-list (setting *PATH_TO_DATA*)))))
;; uses AND logic
;; restricted-to should be a list of record ids if given or a predicate.
;; - sort-by is either a symbol (indicating a record property) or a function on a record
;; that returns a value.
(define (load-where (pairs '())
#:restricted-to (restricted-to #f)
#:type (type-or-types #f)
#:sort-by (sort-by #f)
#:compare (compare <)
#:equal-fn (equal-fn equal?) ; used in pair value equality test
#:exactly-one (exactly-one #f)
#:limit (limit #f))
(let* ((result
(rec-filter-where (cond ((and restricted-to (list? restricted-to))
(map load-rec restricted-to))
(restricted-to
;; then restricted-to is a fn:
(filter restricted-to
(load-all-recs #:type type-or-types)))
(else (load-all-recs #:type type-or-types)))
pairs
#:equal-fn equal-fn))
(sorted (sort-recs-by result sort-by #:compare compare)))
(cond (exactly-one (if (empty? sorted) #f (first sorted)))
(limit (take-up-to sorted limit))
(else sorted))))
;; sort-by is either #f,
;; a symbol (indicating a record property),
;; or a function on a record that returns a value.
(define (sort-recs-by recs sort-by #:compare (compare-fn <))
(if sort-by
(sort recs (lambda (a b)
(if (procedure? sort-by)
(compare-fn (sort-by a) (sort-by b))
(compare-fn (rec-prop a sort-by)
(rec-prop b sort-by)))))
recs))
;; restricted-to should be a list of record ids if given.
(define (load-one-where pairs #:restricted-to (restricted-to #f))
(let ((results (load-where pairs)))
(if (empty? results)
#f
(first results))))
(declare-setting *PATH_TO_DATA* (build-path (current-directory) "data"))
;; persists the given record on disk, overwriting any previous record of the same id
;; that may have been there.
(define (write-record! r)
(let ((id (rec-id r)))
(call-with-output-file (abs-path-to-record id)
(lambda (port)
(write (rec-data r) port))
#:exists 'replace)))
;; returns #f if no such file in data/ directory.
(define (read-record-data id)
(let ((p (abs-path-to-record id)))
(and (file-exists? p)
(call-with-input-file p
(lambda (port)
(read port))))))
;; is the given record stored in the repository?
(define (record-stored? rec)
(record-id-stored? (rec-id rec)))
(define (record-id-stored? rec-id)
(file-exists? (abs-path-to-record rec-id)))
(define (abs-path-to-record id)
(unless (directory-exists? (setting *PATH_TO_DATA*))
(e "Can't find data directory '~A'. Current directory is ~A."
(setting *PATH_TO_DATA*) (current-directory)))
(build-path (setting *PATH_TO_DATA*) id))
;;
;; find-parent
;;
(define (find-parent child-rec child-prop #:parent-type (parent-type #f))
(find-incoming-records child-rec child-prop
#:find-type parent-type
#:is-ptr-to-list #t
#:return-just-one-record #t))
;; is low-rec a (strict) descendant of high-rec?
(define (is-descendant? low-rec high-rec child-ptr-prop)
(any (cut same-rec? <> low-rec) (load-descendants high-rec child-ptr-prop)))
;; like find-parent, but the starting-rec is not part of a list of children coming out
;; of the incoming (parent) rec.
(define (find-incoming-record starting-rec ptr-prop
#:find-type (find-type #f))
(find-incoming-records starting-rec ptr-prop
#:find-type find-type
#:return-just-one-record #t))
;;
;; find-incoming-records
;;
;; You have a record, and want to search for records that point into it (aka, incoming
;; records). If you return-just-one-record and there are no incoming records, then this
;; returns #f.
;;
(define (find-incoming-records starting-rec ptr-prop
#:find-type (find-type #f)
#:is-ptr-to-list (is-ptr-to-list #f)
#:return-just-one-record (just-one #f))
;; XXX we'd like to have this here, but it will require a touch of work on the cache:
;; #:sort-by (sort-by #f)
;; #:compare (compare <))
(let ((clookup (cache-lookup starting-rec find-type ptr-prop)))
(if clookup
(cond ((and just-one (not (empty? clookup))) (first clookup))
(just-one #f)
(else clookup))
;; o/w do it the slow way
(let ((start-rec-id (rec-id starting-rec))
(find-fn (if just-one find filter)))
(find-fn (lambda (outgoing-rec)
(if is-ptr-to-list
(member start-rec-id (rec-child-prop outgoing-rec ptr-prop))
(aand (rec-prop outgoing-rec ptr-prop)
(string=? it start-rec-id))))
(load-where #:type find-type))))))
;;
;; find-ancestor
;;
;; Note that it is acceptable to return the given descendant-rec if pred is satisfied.
;;
(define (find-ancestor descendant-rec pred recursive-child-prop
#:ancestor-type (anc-type #f))
(if (pred descendant-rec)
descendant-rec
(let ((p (find-parent descendant-rec recursive-child-prop #:parent-type anc-type)))
(and p
(find-ancestor p pred recursive-child-prop #:ancestor-type anc-type)))))
(define (find-highest-ancestor descendant-rec recursive-child-prop
#:ancestor-type (anc-type #f))
(let ((p (find-parent descendant-rec recursive-child-prop #:parent-type anc-type)))
(if p
(find-highest-ancestor p recursive-child-prop #:ancestor-type anc-type)
descendant-rec)))
(define (robust-path->string str-or-path)
(if (string? str-or-path)
str-or-path
(path->string str-or-path)))
;; Cache stuff
;; load-fn is called at the beginning of time to load a repository into the cache.
;; store-fn is called when a record is stored (either when a record is created or mutated).
;; delete-fn is called when a record is deleted
;; lookup-fn is called to get a value (quickly) out of the cache.
;; ht is the hash table which is the cache proper.
(define-struct cache-spec (load-fn store-fn delete-fn might-answer-fn lookup-fn ht))
(define-struct type-cache (type-name records) #:mutable)
(define *CACHE_SPECS* (list))
(define *TYPE_CACHES* (list))
(define (add-to-cache-specs! cs)
(set! *CACHE_SPECS* (cons cs *CACHE_SPECS*)))
(define (add-to-type-caches! tc)
(set! *TYPE_CACHES* (cons tc *TYPE_CACHES*)))
;;
;; define-cache
;;
;; When using records, we usually "point" to other records in just one direction.
;; So, for example, each "movie" record might have some "actors" pointing out of it.
;; Thus, we can efficiently ask for the actors in a given movie, but the reverse question
;; ("which movies was this actor in?") is slower since it involves (potentially)
;; looking at each movie to find ones that have the actor.
;;
;; We use easy-to-create caches to make this computation faster. These caches store
;; the "incoming connections", which, in the above example, would correspond to
;; actors to movies. We would define a cache to represent this with
;;
;; (define-cache movies-with-this-actor
;; actors <= (movie))
;;
;; The arrow (<=) indicates the direction of the pointers in the record repository.
;; But to see which way the cache helps you, you just read is left to right (i.e, given
;; an actor, we can find a movie). The parens around "movie" indicate that the "actors"
;; property is a list property.
;;
;; All records in the cache are just stored by id, so if you change a property, the old
;; property will *not* be cached...unless of course you are using some other caching
;; scheme in combination with this which does cache record values.
;;
;; This form binds a name to a hash table which maps record ids (of type implied by the
;; prop-ptr) to either a record or list of records of type incoming-type.
;;
;; When you change a record that is pointed to
;;
(define-syntax define-cache
(syntax-rules (<=)
((_ name prop-ptr <= (incoming-type))
(begin (define name (make-hash))
(add-to-cache-specs! (create-cache-spec name 'prop-ptr 'incoming-type
#:has-many-incoming #t))))
((_ name prop-ptr <= incoming-type)
(begin (define name (make-hash))
(add-to-cache-specs! (create-cache-spec name 'prop-ptr 'incoming-type))))))
;;
;; define-type-cache
;;
;; type caches give you fast access to records of a particular type.
;;
;; Example usage:
;; (define-type-cache movie)
;;
(define-syntax define-type-cache
(syntax-rules ()
((_ type)
(add-to-type-caches! (make-type-cache 'type (list))))))
(define (create-cache-spec ht prop-ptr incoming-type
;; XXX we aren't using has-many-incoming yet
#:has-many-incoming (has-many-incoming #f))
(define (add! incoming-rec points-to-id)
(hash-set! ht points-to-id (cons (rec-id incoming-rec)
(hash-ref ht points-to-id '()))))
(define (remove! incoming-rec formerly-pointed-to-id)
(hash-set! ht formerly-pointed-to-id (removef (cute string=? <> (rec-id incoming-rec))
(hash-ref ht formerly-pointed-to-id))))
(define i-care? (cut rec-type-is? <> incoming-type))
(define (load-fn incoming-rec)
(when (i-care? incoming-rec)
(awhen (rec-prop incoming-rec prop-ptr)
(for-each (cut add! incoming-rec <>) (listify it)))))
;; this should be called before the store actually happens so we can get access to the
;; "pre-store" data
(define (store-fn incoming-rec)
(when (i-care? incoming-rec)
(let ((old-ptrs (and (record-stored? incoming-rec)
(rec-prop (load-rec (rec-id incoming-rec)) prop-ptr)))
(new-ptrs (rec-prop incoming-rec prop-ptr)))
(unless (equal? old-ptrs new-ptrs)
(when old-ptrs
(for-each (cut remove! incoming-rec <>) (listify old-ptrs)))
(load-fn incoming-rec)))))
(define (delete-fn incoming-rec)
(when (i-care? incoming-rec)
(awhen (rec-prop incoming-rec prop-ptr)
(for-each (cut remove! incoming-rec <>) (listify it)))))
(define (might-answer-fn a-incoming-type a-prop-ptr)
(and (eq? incoming-type a-incoming-type)
(eq? prop-ptr a-prop-ptr)))
;; only call this if might-answer? is #t
(define (lookup-fn a-rec a-incoming-type a-prop-ptr)
(hash-ref ht (rec-id a-rec) '()))
(make-cache-spec load-fn store-fn delete-fn might-answer-fn lookup-fn ht))
;; Basic cache ops follow. these are used for both incoming ptr caches, and
;; type caches. In the case of incoming ptr caches, for cache-load, cache-store,
;; cache-delete and cache-lookup, you should consider the given rec as the "incoming rec".
;; this happens when the server is started
(define (cache-load rec)
;; incoming ptr cache load:
(for-each (lambda (spec) ((cache-spec-load-fn spec) rec))
*CACHE_SPECS*)
;; type cache load:
(add-record-to-type-cache! rec))
(define (cache-store rec)
;; store in main caches:
(for-each (lambda (spec) ((cache-spec-store-fn spec) rec))
*CACHE_SPECS*)
;; store in type cache:
(add-record-to-type-cache! rec))
(define (cache-delete rec)
;; delete from main caches:
(for-each (lambda (spec) ((cache-spec-delete-fn spec) rec))
*CACHE_SPECS*)
;; delete from type cache:
(delete-record-from-type-cache! rec))
;; returns #f if no caches apply
(define (cache-lookup starting-rec incoming-type prop-ptr)
(let ((appro-spec (find (lambda (spec)
((cache-spec-might-answer-fn spec) incoming-type prop-ptr))
*CACHE_SPECS*)))
(and appro-spec
(map load-rec
((cache-spec-lookup-fn appro-spec) starting-rec incoming-type prop-ptr)))))
;; returns #f (if there is no cache to answer this question)
;; or o/w a list of all records of the given type
(define (type-cache-get-records type-name)
(aand (find-type-cache-with-name type-name)
(type-cache-records it)))
(define (find-type-cache rec)
(find-type-cache-with-name (rec-type rec)))
(define (find-type-cache-with-name type-name)
(find (lambda (type-cache) (eq? type-name (type-cache-type-name type-cache)))
*TYPE_CACHES*))
;; if the rec is already in the type cache, this replaces it. This might be a future point
;; of optimization because we aren't being efficient here.
(define (add-record-to-type-cache! rec)
(let ((id (rec-id rec)))
(awhen (find-type-cache rec)
(let ((recs-in-cache (type-cache-records it)))
(set-type-cache-records! it (cons rec
(if (record-id-stored? id)
;; xxx: technically we can stop once we
;; found it.
(removef (cut id-is? <> id) recs-in-cache)
recs-in-cache)))))))
(define (delete-record-from-type-cache! rec)
(awhen (find-type-cache rec)
(let ((its-id (rec-id rec)))
(set-type-cache-records! it (removef (lambda (r) (string=? (rec-id r) its-id))
(type-cache-records it))))))
(define (populate-caches)
(server-log "Populating caches...")
(for-each cache-load (load-all-recs))
(server-log "Done populating cache."))
Jump to Line
Something went wrong with that request. Please try again.