#lang scheme/base
(require scheme/class
scheme/contract
srfi/26/cut)
(require (file "../snooze.ss")
(file "cache.ss")
(file "entity.ss"))
(define-persistent-struct audit-attribute
([entity-id (make-integer-type #f #f)]
[name (make-symbol-type #f #f 32)]))
(define attribute-cache%
(class* object% (attribute-cache<%>)
(init-field snooze)
(init-field entity-cache)
(super-new)
(define forward-cache (make-hash))
(define reverse-cache (make-hasheq))
(define-alias ENTITY audit-entity)
(define-alias ATTR audit-attribute)
(define/public (attribute->id attr)
(cond [(memory-forward-lookup attr)
=> (lambda (id)
id)]
[(database-forward-lookup snooze attr)
=> (lambda (id)
(memory-store! id attr)
id)]
[else (let ([id (database-store! attr)])
(memory-store! id attr)
id)]))
(define/public (id->attribute id)
(cond [(memory-reverse-lookup id)
=> (lambda (attr)
attr)]
[(database-reverse-lookup id)
=> (lambda (attr)
(memory-store! id attr)
attr)]
[else (raise-exn exn:fail:snooze
"Attribute not found in audit metadata: ~s" id)]))
(define/public (clear-cache!)
(set! forward-cache (make-hash))
(set! reverse-cache (make-hash)))
(define (attr->forward-key attr)
(cons (entity-table-name (attribute-entity attr))
(attribute-column-name attr)))
(define (memory-forward-lookup attr)
(hash-ref forward-cache (attr->forward-key attr) #f))
(define (database-forward-lookup snooze attr)
(send snooze find-one
(sql:select #:what ATTR-id
#:from (sql:inner ENTITY ATTR (sql:= ENTITY-id ATTR-entity-id))
#:where (sql:and (sql:= ENTITY-name (entity-table-name (attribute-entity attr)))
(sql:= ATTR-name (attribute-column-name attr))))))
(define (memory-reverse-lookup id)
(hash-ref reverse-cache id #f))
(define (database-reverse-lookup id)
(define names
(send snooze find-one
(sql:select #:what (list ENTITY-name ATTR-name)
#:from (sql:inner ENTITY ATTR (sql:= ENTITY-id ATTR-entity-id))
#:where (sql:= ATTR-id id))))
(entity-attribute (schema-entity (car names)) (cadr names)))
(define (memory-store! id attr)
(hash-set! forward-cache attr id)
(hash-set! reverse-cache id attr))
(define (database-store! attr)
(define entity-id
(send entity-cache entity->id (attribute-entity attr)))
(define audit-attr
(send snooze save! (make-audit-attribute entity-id (attribute-column-name attr))))
(struct-id audit-attr))
(inspect #f)))
(provide (persistent-struct-out audit-attribute)
attribute-cache<%>
attribute-cache%)