#lang scheme/base

(require scheme/class
         scheme/contract
         srfi/26/cut)

(require (file "../snooze.ss")
         (file "cache.ss")
         (file "entity.ss"))

; audit-attributes map attributes to globally unique integers,
; reducing the size-on-disk of records in the audit-delta table.
;
; Attributes are cached in memory for speed and in the database
; for persistence. The attribute-cache% class makes sure the caches
; stay in sync.

; Persistent struct types ------------------------

(define-persistent-struct audit-attribute
  ([entity-id (make-integer-type #f #f)]
   [name      (make-symbol-type #f #f 32)]))

; Cache ------------------------------------------

(define attribute-cache%
  (class* object% (attribute-cache<%>)
    
    ; Constructor --------------------------------
    
    ; snooze<%>
    (init-field snooze)
    
    ; entity-cache<%>
    (init-field entity-cache)
    
    (super-new)
    
    ; Fields -------------------------------------
    
    ; (hashof (cons symbol symbol) integer)
    (define forward-cache (make-hash))
    
    ; (hashof integer attribute)
    (define reverse-cache (make-hasheq))
    
    (define-alias ENTITY audit-entity)
    (define-alias ATTR   audit-attribute)
    
    ; Public methods -----------------------------
    
    ; attribute -> integer
    (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)]))
    
    ; integer -> attribute
    (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)]))
    
    ; -> void
    (define/public (clear-cache!)
      (set! forward-cache (make-hash))
      (set! reverse-cache (make-hash)))
    
    ; Helpers ------------------------------------
    
    ; attribute -> (cons symbol symbol)
    (define (attr->forward-key attr)
      (cons (entity-table-name (attribute-entity attr))
            (attribute-column-name attr)))
    
    ; attribute -> (U integer #f)
    (define (memory-forward-lookup attr)
      (hash-ref forward-cache (attr->forward-key attr) #f))
    
    ; attribute -> (U integer #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))))))
    
    ; integer -> (U attribute #f)
    (define (memory-reverse-lookup id)
      (hash-ref reverse-cache id #f))
    
    ; integer -> attribute
    (define (database-reverse-lookup id)
      ; (list symbol symbol)
      (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)))
    
    ; integer attribute -> void
    (define (memory-store! id attr)
      (hash-set! forward-cache attr id)
      (hash-set! reverse-cache id attr))
    
    ; attribute -> void
    (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 statements -----------------------------

(provide (persistent-struct-out audit-attribute)
         attribute-cache<%>
         attribute-cache%)