Use test suites so raco test shows something.

greghendershott · Aug 31, 2012 · 855ac75 · 855ac75
1 parent 012c4aa
commit 855ac75
Show file tree

Hide file tree

Showing 11 changed files with 598 additions and 574 deletions.
diff --git a/cw.rkt b/cw.rkt
@@ -461,79 +461,81 @@
                        #:dimensions `((InstanceId "i-cfeb8ba4")) )
 
 (module+ test
-  (require rackunit)
-  (require "tests/data.rkt")
-
-  (test-case
-   "describe-alarms"
-   (define xs (describe-alarms))
-   (check-equal? (describe-alarms #:alarm-names (map alarm-name xs))
-                 xs))
-
-  (test-case
-   "put/list/get metric data"
-   (define test-unit 'Percent)
-   (define test-dimensions `((FakeDimensionName "FakeDimensionValue")))
-
-   (define end (current-seconds))
-   (define beg (- end (* 60 101)))        ;101 mintutes earlier
-   (define xs-put
-     (for/list ([n (in-range 0 101 1)]
-                [sc (in-range beg end 60)])
-         (datum (test/metric)
-                n
-                #f #f #f #f
-                test-unit
-                sc
-                test-dimensions)))
-
-   ;; CW doesn't want > 20 at once. So do in batches of 20, which is
-   ;; good to exercise our handling of that.
-   (let loop ([xs xs-put])
-     (define len (length xs))
-     (define this (min len 20))
-     (define next (- len this))
-     (unless (zero? this)
-       (put-metric-data (test/namespace) (take xs this))
-       (unless (zero? next)
-         (loop (take-right xs next)))))
-
-   ;; First time, may take awhile to show up
-   (let loop ([tries 8])
-     (unless (zero? tries)
-       (when (empty? (list-metrics #:namespace (test/namespace)))
-         (sleep 15)
-         (loop (sub1 tries)))))
-
-   (define m (list (metric (test/metric) (test/namespace) '())))
-   (check-equal? (list-metrics #:namespace (test/namespace)) m)
-   (check-equal? (list-metrics #:metric-name (test/metric)) m)
-
-   (define xs-get
-     (get-metric-statistics #:metric-name (test/metric)
-                            #:namespace (test/namespace)
-                            #:unit test-unit
-                            #:statistics '(Sum Average Minimum Maximum
-                                               SampleCount)
-                            #:period 60
-                            #:start-time (- (current-seconds) (* 24 60 60))
-                            #:end-time (current-seconds)
-                            ;; #:dimensions test-dimensions
-                            ))
-   (check-true (not (empty? xs-get)))
-   (check-equal? (remove-duplicates (map datum-metric-name xs-get))
-                 (list (test/metric)))
-   (check-equal? (remove-duplicates (map datum-unit xs-get))
-                 (list test-unit))
-   ;; datum-value should always be #f when returned from
-   ;; get-metric-statistics
-   (check-equal? (remove-duplicates (map datum-value xs-get))
-                 (list #f))
-   ;; We specified all the statistics in #:statistics above, so make
-   ;; sure all are non-#f
-   (check-not-equal? (remove-duplicates (append (map datum-min xs-get)
-                                                (map datum-max xs-get)
-                                                (map datum-sum xs-get)
-                                                (map datum-sample-count xs-get)))
-                     (list #f)))
-  )
+  (require "run-suite.rkt")
+
+  (define/run-test-suite
+   "cw.rkt"
+   (test-case
+    "describe-alarms"
+    (define xs (describe-alarms))
+    (check-equal? (describe-alarms #:alarm-names (map alarm-name xs))
+                  xs))
+
+   (test-case
+    "put/list/get metric data"
+    (define test-unit 'Percent)
+    (define test-dimensions `((FakeDimensionName "FakeDimensionValue")))
+
+    (define end (current-seconds))
+    (define beg (- end (* 60 101)))        ;101 mintutes earlier
+    (define xs-put
+      (for/list ([n (in-range 0 101 1)]
+                 [sc (in-range beg end 60)])
+          (datum (test/metric)
+                 n
+                 #f #f #f #f
+                 test-unit
+                 sc
+                 test-dimensions)))
+
+    ;; CW doesn't want > 20 at once. So do in batches of 20, which is
+    ;; good to exercise our handling of that.
+    (let loop ([xs xs-put])
+      (define len (length xs))
+      (define this (min len 20))
+      (define next (- len this))
+      (unless (zero? this)
+        (put-metric-data (test/namespace) (take xs this))
+        (unless (zero? next)
+          (loop (take-right xs next)))))
+
+    ;; First time, may take awhile to show up
+    (let loop ([tries 8])
+      (unless (zero? tries)
+        (when (empty? (list-metrics #:namespace (test/namespace)))
+          (sleep 15)
+          (loop (sub1 tries)))))
+
+    (define m (list (metric (test/metric) (test/namespace) '())))
+    (check-equal? (list-metrics #:namespace (test/namespace)) m)
+    (check-equal? (list-metrics #:metric-name (test/metric)) m)
+
+    (define xs-get
+      (get-metric-statistics #:metric-name (test/metric)
+                             #:namespace (test/namespace)
+                             #:unit test-unit
+                             #:statistics '(Sum Average Minimum Maximum
+                                                SampleCount)
+                             #:period 60
+                             #:start-time (- (current-seconds) (* 24 60 60))
+                             #:end-time (current-seconds)
+                             ;; #:dimensions test-dimensions
+                             ))
+    (check-true (not (empty? xs-get)))
+    (check-equal? (remove-duplicates (map datum-metric-name xs-get))
+                  (list (test/metric)))
+    (check-equal? (remove-duplicates (map datum-unit xs-get))
+                  (list test-unit))
+    ;; datum-value should always be #f when returned from
+    ;; get-metric-statistics
+    (check-equal? (remove-duplicates (map datum-value xs-get))
+                  (list #f))
+    ;; We specified all the statistics in #:statistics above, so make
+    ;; sure all are non-#f
+    (check-not-equal? (remove-duplicates (append
+                                          (map datum-min xs-get)
+                                          (map datum-max xs-get)
+                                          (map datum-sum xs-get)
+                                          (map datum-sample-count xs-get)))
+                      (list #f)))
+   ))
diff --git a/glacier.rkt b/glacier.rkt
@@ -537,52 +537,55 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (module+ test
-  (require rackunit
-           "tests/data.rkt"
+  (require "run-suite.rkt"
            (planet gh/aws/sns))
 
-  (define vault (test/vault))
-
-  (define topic-arn (create-topic (test/topic)))
-
-  (check-true (create-vault vault))
-  (check-true (for/or ([x (in-list (list-vaults))])
-                  (define name (hash-ref x 'VaultName #f))
-                (and name (string=? name vault))))
-
-  (define id #f)
-
-  (check-not-exn
-   (lambda () (set! id (create-archive vault "description" #"Hello, world"))))
-  (check-true (delete-archive vault id))
-
-  (check-not-exn
-   (lambda ()
-     (set! id (create-archive vault "description"
-                              (make-bytes (+ 3 (* 4 1MB)))))))
-  (check-true (delete-archive vault id))
-
-  (check-not-exn
-   (lambda ()
-     (set! id (create-archive/multipart-upload vault "description" 1MB
-                                               (make-bytes (+ 3 (* 4 1MB)))))))
-  (check-true (delete-archive vault id))
-
-  (check-not-exn
-   (lambda ()
-     (set! id (create-archive-from-file vault
-                                        (build-path 'same "manual.scrbl")))))
-  (check-true (delete-archive vault id))
-
-  ;; Unfortunately the retrieve-XXX operations take 3-5 hours to
-  ;; complete, so it's impractical for our unit test to check the SNS
-  ;; topic. Furthermore, retrieve-inventory may fail during the first 24
-  ;; hours after a vault is created, because Amazon Glacier hasn't
-  ;; created an initial inventory yet. Gah.
-
-  ;; (define job-id (retrieve-inventory vault "" topic-arn))
-  ;; (list-jobs)
-
-  (check-not-exn
-   (lambda () (set-vault-notifications vault topic-arn #t #t)))
-  )
+  (define/run-test-suite
+   "glacier.rkt"
+   (test-case
+    "glacier"
+    (define vault (test/vault))
+
+    (define topic-arn (create-topic (test/topic)))
+
+    (check-true (create-vault vault))
+    (check-true (for/or ([x (in-list (list-vaults))])
+                    (define name (hash-ref x 'VaultName #f))
+                  (and name (string=? name vault))))
+
+    (define id #f)
+
+    (check-not-exn
+     (lambda () (set! id (create-archive vault "description" #"Hello, world"))))
+    (check-true (delete-archive vault id))
+
+    (check-not-exn
+     (lambda ()
+       (set! id (create-archive vault "description"
+                                (make-bytes (+ 3 (* 4 1MB)))))))
+    (check-true (delete-archive vault id))
+
+    (check-not-exn
+     (lambda ()
+       (set! id (create-archive/multipart-upload vault "description" 1MB
+                                                 (make-bytes (+ 3 (* 4 1MB)))))))
+    (check-true (delete-archive vault id))
+
+    (check-not-exn
+     (lambda ()
+       (set! id (create-archive-from-file vault
+                                          (build-path 'same "manual.scrbl")))))
+    (check-true (delete-archive vault id))
+
+    ;; Unfortunately the retrieve-XXX operations take 3-5 hours to
+    ;; complete, so it's impractical for our unit test to check the SNS
+    ;; topic. Furthermore, retrieve-inventory may fail during the first 24
+    ;; hours after a vault is created, because Amazon Glacier hasn't
+    ;; created an initial inventory yet. Gah.
+
+    ;; (define job-id (retrieve-inventory vault "" topic-arn))
+    ;; (list-jobs)
+
+    (check-not-exn
+     (lambda () (set-vault-notifications vault topic-arn #t #t)))
+    )))
diff --git a/post.rkt b/post.rkt
@@ -7,9 +7,6 @@
          "exn.rkt"
          "util.rkt")
 
-;;; Some functions used by both SQS and SDB
-;;; This module probably needs a better name/organization.
-
 (define/contract/provide (post-with-retry uri xs-post-data heads [try 1])
   ((string? dict? dict?)
    (exact-positive-integer?)

diff --git a/run-suite.rkt b/run-suite.rkt
@@ -0,0 +1,16 @@
+#lang racket
+
+(require rackunit
+         rackunit/text-ui
+         "tests/data.rkt")
+
+(define-syntax-rule (define/run-test-suite name body0 body ...)
+  (begin
+    (printf "~a ... " name)
+    (flush-output)
+    (void (run-tests (test-suite name body0 body ...) 'normal))))
+
+(provide (all-from-out rackunit)
+         (all-from-out rackunit/text-ui)
+         (all-from-out "tests/data.rkt")
+         define/run-test-suite)