#lang scheme/base

(require mzlib/etc
         scheme/class
         scheme/match
         srfi/19/time
         srfi/26/cut
         (planet untyped/unlib:3/time)
         (planet untyped/unlib:3/pipeline)
         "../snooze.ss"
         "../test-base.ss"
         "../test-data.ss"
         "../test-util.ss"
         "audit.ss")

; Tests ----------------------------------------

(define-audit-transaction audit-transaction
  ([message (make-string-type #t #f #f)]))

; snooze% -> test-suite
(define (make-audit-tests snooze)
  (define-snooze-interface snooze)
  
  ; audit-trail<%>
  (define trail 
    (make-audit-trail snooze
                      entity:audit-transaction
                      (list entity:course entity:person entity:pet)))
  
  (define-audit-interface trail)
  
  (define-alias ENTITY audit-entity)
  (define-alias ATTR   audit-attribute)
  (define-alias TXN    audit-transaction)
  (define-alias DELTA  audit-delta)
  
  ; -> (listof audit-attribute)
  (define (find-attrs)
    (find-all (sql:select #:from ATTR)))
  
  ; -> (listof audit-transaction)
  (define (find-txns)
    (find-all (sql:select #:from TXN #:order (list (sql:asc TXN-id)))))
  
  ; -> (listof audit-delta)
  (define (find-deltas)
    (find-all (sql:select #:from DELTA #:order (list (sql:asc DELTA-id)))))
  
  ; -> void
  (define (clear-trail!)
    (send trail clear!))
  
  ; entity attribute persistent-struct -> (listof any)
  (define (find-history entity attr struct)
    (map (cut audit-delta-value <> (attribute-type attr))
         (find-all (sql:select #:what  DELTA
                               #:from  (sql:inner (sql:inner ENTITY ATTR (sql:= ENTITY-id ATTR-entity-id))
                                                  DELTA (sql:= ATTR-id DELTA-attribute-id))
                               #:where (sql:and (sql:= ENTITY-name (entity-table-name entity))
                                                (sql:= ATTR-name (attribute-column-name attr))
                                                (sql:= DELTA-struct-id (struct-id struct)))
                               #:order (list (sql:asc DELTA-id))))))
  
  ; test-suite
  (test-suite "audit"
    
    #:before
    (lambda ()
      (drop-table entity:audit-attribute)
      (drop-table entity:audit-transaction)
      (drop-table entity:audit-delta)
      (send trail init!)
      (for-each create-table (list entity:course entity:person entity:pet)))
    
    #:after
    (lambda ()
      (drop-table entity:audit-attribute)
      (drop-table entity:audit-transaction)
      (drop-table entity:audit-delta)
      (drop-table entity:course)
      (drop-table entity:person))
    
    ; Initialising -------------------------------
    
    (test-case "init-audit-trail!"
      (check-true (table-exists? entity:audit-attribute) "check 3")
      (check-true (table-exists? entity:audit-transaction) "check 4")
      (check-true (table-exists? entity:audit-delta) "check 5")
      
      (check-pred stage? (find-stage (send snooze get-transaction-pipeline) 'transaction-stage) "check 6")
      (check-pred stage? (find-stage (entity-insert-pipeline entity:person) 'insert-stage) "check 7")
      (check-pred stage? (find-stage (entity-update-pipeline entity:person) 'update-stage) "check 8")
      (check-pred stage? (find-stage (entity-delete-pipeline entity:person) 'delete-stage) "check 9")
      (check-pred stage? (find-stage (entity-insert-pipeline entity:pet) 'insert-stage) "check 10")
      (check-pred stage? (find-stage (entity-update-pipeline entity:pet) 'update-stage) "check 11")
      (check-pred stage? (find-stage (entity-delete-pipeline entity:pet) 'delete-stage) "check 12"))
    
    ; Auditing changes ---------------------------
    
    (test-case "audit-attributes generated correctly"
      (fail "Not implemented."))
    
    (test-case "audit basic insert, update and delete"
      (begin-with-definitions
        (clear-trail!)
        
        (check-pred null? (find-txns) "check 1")
        (check-pred null? (find-deltas) "check 2")
        
        (define person1 (save! (make-person "Dave")))
        
        (check-equal? (length (find-txns)) 1 "check 3")
        (check-equal? (length (find-deltas)) 1 "check 4")
        
        (define person2 (save! (copy-person person1 #:name "Noel")))
        
        (check-equal? (length (find-txns)) 2 "check 5")
        (check-equal? (length (find-deltas)) 2 "check 6")
        
        (delete! person2)
        
        (check-equal? (length (find-txns)) 3 "check 7")
        (check-equal? (length (find-deltas)) 3 "check 8")))
    
    (test-case "audit sequence"
      (begin-with-definitions
        (clear-trail!)
        
        (define-values (person1 person2)
          (apply values (call-with-transaction
                         (lambda ()
                           (list (save! (make-person "Dave"))
                                 (save! (make-person "Noel"))))
                         "0")))
        
        (define deltas (find-deltas))
        
        (check-equal? (audit-delta-struct-id (car deltas))  (struct-id person1) "check person1")
        (check-equal? (audit-delta-struct-id (cadr deltas)) (struct-id person2) "check person2")))
    
    (test-case "audit the different attribute types"
      (begin-with-definitions
        (define time (string->time-tai "2001-01-01 01:01:01"))
        (define course (save! (make-course 'COURSE "Course" 123 1.23 #t time)))
        
        (clear-trail!)
        
        (save! (copy-course course
                            #:code   'ESRUOC
                            #:name   "esruoC"
                            #:value  321
                            #:rating 3.21
                            #:active #f
                            #:start  (current-time time-tai)))
        
        (check-equal? (find-history entity:course attr:course-id       course) (list)          "check 1")
        (check-equal? (find-history entity:course attr:course-revision course) (list)          "check 2")
        (check-equal? (find-history entity:course attr:course-code     course) (list 'COURSE)  "check 3")
        (check-equal? (find-history entity:course attr:course-name     course) (list "Course") "check 4")
        (check-equal? (find-history entity:course attr:course-value    course) (list 123)      "check 5")
        (check-equal? (find-history entity:course attr:course-rating   course) (list 1.23)     "check 6")
        (check-equal? (find-history entity:course attr:course-start    course) (list time)     "check 7")
        
        (check-true (andmap (lambda (delta)
                              (eq? (audit-delta-struct-id delta) (struct-id course)))
                            (find-deltas))
                    "check 8")
        
        (check-true (andmap (lambda (delta)
                              (eq? (audit-delta-struct-revision delta) (struct-revision course)))
                            (find-deltas))
                    "check 9")))
    
    (test-case "audit insert/update sequence correctly summarised"
      (begin-with-definitions
        
        (clear-trail!)
        
        (define person
          (call-with-transaction
           (lambda ()
             (let ([ans (save! (make-person "Dave"))])
               (save! (copy-person ans #:name "Noel"))))
           "insert/update sequence"))
        
        (define txns (find-txns))
        (define deltas (find-deltas))
        
        (check-equal? (length txns) 1 "check 1")
        (check-equal? (audit-transaction-message (car txns)) "insert/update sequence" "check 2")
        
        (check-equal? (length deltas) 2 "check 3")
        (check-equal? (car deltas)
                      (copy-audit-delta (make-insert-delta (car txns) (struct-guid person))
                                        #:id       (struct-id (car deltas))
                                        #:revision 0)
                      "check 4")
        (check-equal? (cadr deltas)
                      (copy-audit-delta (make-update-delta (car txns) (struct-guid person) 0 attr:person-name "Dave")
                                        #:id       (struct-id (cadr deltas))
                                        #:revision 0)
                      "check 5")))
    
    (test-case "insert/delete sequence correctly summarised"
      (begin-with-definitions
        
        (clear-trail!)
        
        (define person
          (call-with-transaction
           (lambda ()
             (define ans (save! (make-person "Dave")))
             (delete! (copy-person ans))
             ans)
           "insert/delete sequence"))
        
        (define txns (find-txns))
        (define deltas (find-deltas))
        
        (check-equal? (length txns) 1 "check 1")
        (check-equal? (audit-transaction-message (car txns)) "insert/delete sequence" "check 2")
        
        (check-equal? (length deltas) 2 "check 3")
        (check-equal? (car deltas)
                      (copy-audit-delta (make-insert-delta (car txns) (struct-guid person))
                                        #:id       (struct-id (car deltas))
                                        #:revision 0)
                      "check 4")
        (check-equal? (cadr deltas)
                      (copy-audit-delta (make-delete-delta (car txns) (struct-guid person) 0 attr:person-name "Dave")
                                        #:id       (struct-id (cadr deltas))
                                        #:revision 0)
                      "check 5")))
    
    (test-case "update/update sequence correctly summarised"
      (begin-with-definitions
        
        (clear-trail!)
        
        (define person
          (let ([ans (save! (make-person "Dave"))])
            (clear-trail!)
            (call-with-transaction
             (lambda ()
               (save! (copy-person (save! (copy-person ans #:name "Noel")) #:name "Matt")))
             "update/update sequence")
            ans))
        
        (define txns (find-txns))
        (define deltas (find-deltas))
        
        (check-equal? (length txns) 1 "check 1")
        (check-equal? (audit-transaction-message (car txns)) "update/update sequence" "check 2")
        (check-equal? (length deltas) 2 "check 3")
        (check-equal? (car deltas)
                      (copy-audit-delta (make-update-delta (car txns) (struct-guid person) 0 attr:person-name "Dave")
                                        #:id       (struct-id (car deltas))
                                        #:revision 0)
                      "check 4")
        (check-equal? (cadr deltas)
                      (copy-audit-delta (make-update-delta (car txns) (struct-guid person) 1 attr:person-name "Noel")
                                        #:id       (struct-id (cadr deltas))
                                        #:revision 0)
                      "check 5")))
    
    (test-case "audit update/delete sequence correctly summarised"
      (begin-with-definitions
        
        (clear-trail!)
        
        (define person
          (let ([ans (save! (make-person "Dave"))])
            (clear-trail!)
            (call-with-transaction
             (lambda ()
               (delete! (save! (copy-person ans #:name "Noel"))))
             "update/delete sequence")
            ans))
        
        (define txns (find-txns))
        (define deltas (find-deltas))
        
        (check-equal? (length txns) 1 "check 1")
        (check-equal? (audit-transaction-message (car txns)) "update/delete sequence" "check 2")
        (check-equal? (length deltas) 2 "check 3")
        (check-equal? (car deltas)
                      (copy-audit-delta (make-update-delta (car txns) (struct-guid person) 0 attr:person-name "Dave")
                                        #:id       (struct-id (car deltas))
                                        #:revision 0)
                      "check 4")
        (check-equal? (cadr deltas)
                      (copy-audit-delta (make-delete-delta (car txns) (struct-guid person) 1 attr:person-name "Noel")
                                        #:id       (struct-id (cadr deltas))
                                        #:revision 0)
                      `                      "check 5")))
    
    (test-case "audit trail not written when transaction aborted"
      (before (clear-trail!)
              (begin-with-definitions
                
                (let/ec escape
                  (call-with-transaction
                   (lambda ()
                     (save! (make-person "Dave"))
                     (escape #f))
                   "aborted with escape continuation"))
                
                (define txns (find-txns))
                (define deltas (find-deltas))
                
                (check-equal? (length txns) 0 "check 1")
                (check-equal? (length deltas) 0 "check 2"))))
    
    (test-case "nested transaction audited at outermost transaction"
      (before (clear-trail!)
              (begin-with-definitions
                
                (let/ec escape
                  (call-with-transaction
                   (lambda ()
                     (save! (make-person "Dave"))
                     (call-with-transaction
                      (lambda ()
                        (save! (make-person "Noel")))
                      "first inner")
                     (call-with-transaction
                      (lambda ()
                        (save! (make-person "Matt")))
                      "second inner"))
                   "outer"))
                
                (define txns (find-txns))
                (define deltas (find-deltas))
                
                (check-equal? (length txns) 1 "check 1`")
                (check-equal? (length deltas) 3 "check 2")
                
                (check-true (andmap (lambda (delta)
                                      (equal? (audit-delta-transaction-id delta)
                                              (audit-transaction-id (car txns))))
                                    deltas)
                            "check 3"))))
    
    (test-case "inner transaction aborted"
      (begin-with-definitions
        
        (define dave (save! (make-person "Dave")))
        (define noel (save! (make-person "Noel")))
        
        (clear-trail!)
        
        (call-with-transaction
         (lambda ()
           (call-with-transaction
            (lambda ()
              (set-person-name! dave "Dave 2")
              (save! dave))
            "Inner 2")
           (let/ec escape
             (call-with-transaction
              (lambda ()
                (set-person-name! dave "Dave 3")
                (set-person-name! noel "Noel 2")
                (save! dave)
                (save! noel)
                (escape #f))
              "Inner 1"))
           "Outer"))
        
        (define txns (find-txns))
        (define deltas (find-deltas))
        
        (check-equal? (length txns) 1 "check 1") ; Outer transaction only
        (check-equal? (length deltas) 1 "check 2")
        
        (check-true (andmap (lambda (delta)
                              (= (audit-delta-struct-id delta) (struct-id dave)))
                            deltas)
                    "check 3a")
        
        (check-true (andmap (lambda (delta)
                              (= (audit-delta-struct-revision delta) (sub1 (struct-revision dave))))
                            deltas)
                    "check 3b")
        
        (check-equal? (person-name dave) "Dave 2" "check 4") ; Make sure structs are rolled back correctly
        (check-equal? (person-name noel) "Noel" "check 5"))) ; Make sure structs are rolled back correctly
    
    ; Querying and rollback ----------------------
    
    (test-case "audit-transaction-deltas"
      (before (clear-trail!)
              (begin-with-definitions
                (define person1 (save! (make-person "Dave")))
                
                (define txns (find-txns))
                (define person1-txn (car txns))
                
                (define deltas (audit-transaction-deltas person1-txn))
                
                (check-equal? deltas (find-deltas) "check 1"))))
    
    (test-case "id->attribute"
      (before (clear-trail!)
              (begin-with-definitions
                (define person1 (save! (make-person "Dave")))
                (save! (copy-person person1 #:name "Noel"))
                
                ; audit-attribute
                (define audit-attr (car (find-attrs)))
                
                ; attribute
                (define attr (id->attribute (struct-id audit-attr)))
                
                (check-eq? attr attr:person-name "check 1"))))
    
    (test-case "audit-deltas->guids"
      (begin-with-definitions
        (define noel (save! (make-person "Noel")))
        (define william (save! (make-pet (struct-id noel) "William")))
        (define henry (save! (make-pet (struct-id noel) "Henry")))
        
        (clear-trail!)
        
        (call-with-transaction
         (lambda ()
           (set-pet-name! william "Henry")
           (set-pet-name! henry "William")
           (save! william)
           (save! henry))
         "Swapping cat names")
        
        ; audit-transaction
        (define txn (car (find-txns)))
        
        ; (listof audit-delta)
        (define deltas (audit-transaction-deltas txn))
        
        ; (listof guid)
        (define guids (audit-deltas->guids deltas))
        
        (check-not-false (member (struct-guid william) guids) "check 1")
        (check-not-false (member (struct-guid henry) guids) "check 2")
        (check-false (member (struct-guid noel) guids) "check 3")))
    
    (test-case "audit-struct-history"
      (begin-with-definitions
        (clear-trail!)
        
        (define noel (save! (make-person "Noel")))
        (set-person-name! noel "Dave")
        (save! noel)
        (set-person-name! noel "Matt")
        (save! noel)
        (save! (make-person "Bree"))
        (save! (make-pet (struct-id noel) "William"))
        (save! (make-pet (struct-id noel) "Henry"))
        
        ; audit-transaction ; the INSERT transaction
        (define txn (car (find-txns)))
        
        ; (listof audit-delta)
        (define history (audit-struct-history (struct-guid noel) txn))
        
        ; (listof audit-delta)
        (define insert-history 
          (filter (lambda (delta) (equal? (audit-delta-type delta) 'I))
                  history))
        
        ; (listof audit-delta)
        (define id-history 
          (filter (lambda (delta) (equal? (audit-delta-attribute delta) attr:person-id))
                  history))
        
        ; (listof audit-delta)
        (define revision-history 
          (filter (lambda (delta) (equal? (audit-delta-attribute delta) attr:person-revision))
                  history))
        
        ; (listof audit-delta)
        (define name-history 
          (filter (lambda (delta) (equal? (audit-delta-attribute delta) attr:person-name))
                  history))
        
        (check-equal? (length history) 3 "check 0")
        (check-equal? (length insert-history) 1 "check insert")
        (check-equal? (audit-delta-attribute (car insert-history)) #f "check insert attribute")
        (check-equal? (length id-history) 0 "check id")
        (check-equal? (length revision-history) 0 "check revision")
        (check-equal? (length name-history) 2 "check name")
        (check-equal? (map (cut audit-delta-value <> type:string) name-history) (list "Dave" "Noel") "check name values")))
    
    (test-case "revert-delta!: single update"
      (begin-with-definitions
        (define noel (save! (make-person "Noel")))
        
        (define noel-id (struct-id noel))
        
        (clear-trail!)
        
        (set-person-name! noel "Dave")
        (save! noel)
        
        ; audit-transaction ; the UPDATE transaction
        (define txn (car (find-txns)))
        
        ; (listof audit-delta)
        (define history (audit-struct-history (struct-guid noel) txn))
        
        (foldl (cut revert-delta! (struct-guid noel) <> <>)
               noel
               history)
        
        (check-equal? (person-name noel) "Noel" "check 1")
        (check-equal? (struct-revision noel) 1 "check 2 - revision not reverted")
        (check-equal? (struct-id noel) noel-id "check 3")))
    
    (test-case "revert-delta!: insert, update and delete"
      (begin-with-definitions
        (define noel (save! (make-person "Noel")))
        (define dave (save! (make-person "Dave")))
        
        (define noel-id (struct-id noel))
        (define dave-id (struct-id dave))
        
        (define noel-guid (struct-guid noel))
        (define dave-guid (struct-guid dave))
        
        (clear-trail!)
        
        (set-person-name! noel "Noel 2.0")
        (save! noel)
        (delete! dave)
        (define matt (save! (make-person "Matt"))) 
        (define matt-guid (struct-guid matt))
        
        ; audit-transaction ; the UPDATE transaction
        (define txn (car (find-txns)))
        
        (define original-noel (foldl (cut revert-delta! noel-guid <> <>) noel (audit-struct-history noel-guid txn)))
        (define original-dave (foldl (cut revert-delta! dave-guid <> <>) dave (audit-struct-history dave-guid txn)))
        (define original-matt (foldl (cut revert-delta! matt-guid <> <>) matt (audit-struct-history matt-guid txn)))
        
        (check-equal? (person-name original-noel) "Noel" "check 1")
        (check-equal? (struct-revision original-noel) 1 "check 2 - revision not reverted")
        (check-equal? (struct-id original-noel) noel-id "check 3")
        (check-equal? (person-name original-dave) "Dave" "check 4")
        (check-equal? (struct-revision original-dave) 0 "check 5 - revision not reverted")
        (check-equal? (struct-id original-dave) dave-id "check 6")
        (check-equal? original-matt #f "check 7")))
    
    (test-case "audit-snapshot"
      (begin-with-definitions
        (define noel (save! (make-person "Noel")))
        (define dave (save! (make-person "Dave")))
        
        (define noel-id (struct-id noel))
        (define dave-id (struct-id dave))
        
        (define noel-guid (struct-guid noel))
        (define dave-guid (struct-guid dave))
        
        (clear-trail!)
        
        (set-person-name! noel "Noel 2.0")
        (save! noel)
        (delete! dave)
        (define matt (save! (make-person "Matt"))) 
        (define matt-guid (struct-guid matt))
        
        ; audit-transaction ; the UPDATE transaction
        (define txn (car (find-txns)))
        
        (define original-noel (audit-struct-snapshot noel-guid (audit-struct-history noel-guid txn)))
        (define original-dave (audit-struct-snapshot dave-guid (audit-struct-history dave-guid txn)))
        (define original-matt (audit-struct-snapshot matt-guid (audit-struct-history matt-guid txn)))
        
        (check-equal? (person-name original-noel) "Noel" "check original-noel name")
        (check-equal? (struct-revision original-noel) 1 "check original-noel revision unchanged")
        (check-equal? (struct-id original-noel) noel-id "check check original-noel id")
        (check-equal? (person-name original-dave) "Dave" "check original-dave name")
        (check-equal? (struct-revision original-dave) 0 "check check original-dave revision unchanged")
        (check-equal? (struct-id original-dave) dave-id "check check original-dave id")
        (check-equal? original-matt #f "check original-matt #f")
        
        (define intermediate-noel (audit-struct-snapshot noel-guid (audit-struct-history noel-guid txn #f)))
        (define intermediate-dave (audit-struct-snapshot dave-guid (audit-struct-history dave-guid txn #f)))
        (define intermediate-matt (audit-struct-snapshot matt-guid (audit-struct-history matt-guid txn #f)))
        
        (check-equal? (person-name intermediate-noel) "Noel 2.0" "check intermediate-noel name")
        (check-equal? (struct-revision intermediate-noel) 1 "check intermediate-noel revision unchanged")
        (check-equal? (struct-id intermediate-noel) noel-id "check intermediate-noel id")
        (check-equal? (person-name intermediate-dave) "Dave" "check intermediate-dave name")
        (check-equal? (struct-revision intermediate-dave) 0 "check intermediate-dave revision")
        (check-equal? (struct-id intermediate-dave) dave-id "check intermediate-dave id")
        (check-equal? intermediate-matt #f "check intermediate-matt #f")))
    
    (test-case "audit-transaction-affected"
      (begin-with-definitions
        (clear-trail!)
        
        (match-define 
         (list noel dave)
         (call-with-transaction
          (lambda ()
            (list (save! (make-person "Noel"))
                  (save! (make-person "Dave"))))
          "0"))
        
        (define matt
          (call-with-transaction 
           (lambda ()
             (save! (copy-person dave #:name "Dave II"))
             (save! (make-person "Matt")))
           "1"))
        
        (define bree
          (call-with-transaction
           (lambda ()
             (save! (make-person "Bree")))
           "2"))
        
        (call-with-transaction
         (lambda ()
           (set-person-name! matt "Matt the Second")
           (save! matt))
         "3")
        
        (define william
          (call-with-transaction
           (lambda ()
             (save! (copy-person matt #:name "Matt the Third"))
             (save! (make-pet #f "William")))
           "4"))
        
        (define affected (audit-transaction-affected (car (find-txns))))
        
        (define-values (txn0 txn1 txn2 txn3 txn4)
          (apply values (find-txns)))
        
        (check-equal? (hash-ref affected (struct-guid noel) #f) txn0 "check 1")
        (check-equal? (hash-ref affected (struct-guid dave) #f) txn0 "check 2")
        (check-equal? (hash-ref affected (struct-guid matt) #f) txn1 "check 3")
        (check-equal? (hash-ref affected (struct-guid bree) #f) #f "check 4")
        (check-equal? (hash-ref affected (struct-guid william) #f) txn4 "check 5")))
    
    (test-case "audit-roll-back!"
      (begin-with-definitions
        (clear-trail!)
        
        (match-define 
         (list noel dave)
         (call-with-transaction
          (lambda ()
            (list (save! (make-person "Noel"))
                  (save! (make-person "Dave"))))
          "0"))
        
        (define matt
          (call-with-transaction 
           (lambda ()
             (save! (copy-person dave #:name "Dave II"))
             (save! (make-person "Matt")))
           "1"))
        
        (define bree
          (call-with-transaction 
           (lambda ()
             (save! (make-person "Bree")))
           "2"))
        
        (call-with-transaction
         (lambda ()
           (set-person-name! matt "Matt the Second")
           (save! matt))
         "3")
        
        (define william
          (call-with-transaction
           (lambda ()
             (save! (copy-person matt #:name "Matt the Third"))
             (save! (make-pet #f "William")))
           "4"))
        
        (define txn1 (cadr (find-txns)))
        
        (define affected (audit-transaction-affected txn1))
        
        (audit-roll-back! affected "Rollback 1")
        
        (define txns (find-txns))
        
        (check-equal? (length txns) 6 "check 1")
        (check-equal? (map audit-transaction-message txns) 
                      (list "0" "1" "2" "3" "4" "Rollback 1")
                      "check 2")
        (check-equal? (person-name (find-by-id entity:person (struct-id dave))) "Dave" "check 3")
        (check-equal? (person-name (find-by-id entity:person (struct-id noel))) "Noel" "check 4")
        (check-false  (find-by-id entity:person (struct-id matt)) "check 5")
        (check-equal? (find-by-id entity:person (struct-id bree)) bree "check 4")
        (check-false  (find-by-id entity:pet (struct-id william)) "check 6")))))

; Provide statements -----------------------------

(provide make-audit-tests)