Merge pull request #16 from Bogdanp/master

.github/workflows/push.yml

@@ -0,0 +1,20 @@
+on: push
+name: CI
+jobs:
+  build:
+    runs-on: ubuntu-latest
+    strategy:
+      matrix:
+        racket-version:
+          - stable
+          - current
+    steps:
+    - uses: actions/checkout@master
+    - uses: Bogdanp/setup-racket@v1.11
+      with:
+        architecture: 'x64'
+        distribution: 'full'
+        version: ${{ matrix.racket-version }}
+    - run: sudo raco pkg update net-cookies{-lib,-doc,}/
+    - run: raco pkg install --auto net-cookies-test/
+    - run: raco test -x -p net-cookies

README.md

@@ -1,6 +1,6 @@
 # racket-cookies
 
-[![Build Status](https://travis-ci.org/RenaissanceBug/racket-cookies.png?branch=travis-support)](https://travis-ci.org/RenaissanceBug/racket-cookies) 
+[![Build Status](https://github.com/RenaissanceBug/racket-cookies/actions/workflows/push.yml/badge.svg)](https://github.com/RenaissanceBug/racket-cookies/actions/workflows/push.yml)
 ![LGPL 3.0 license](https://img.shields.io/badge/License-LGPL3.0-blue.svg)
 
 This package provides two RFC6265-compliant cookie libraries for Racket:

net-cookies-test/info.rkt

@@ -10,6 +10,7 @@
 
 (define build-deps
   '("net-cookies-lib"
+    "rackcheck-lib"
     "rackunit-lib"))
 
 (define update-implies '("net-cookies-lib"))

net-cookies-test/tests/net/cookies/common.rkt

@@ -1,12 +1,17 @@
 #lang racket
 
-(require rackunit net/cookies/common)
+(require net/cookies/common
+         rackcheck
+         rackunit)
 
 (module+ main
   (require rackunit/text-ui)
   (run-tests cookie-name-tests)
+  (run-tests cookie-name-prop-tests)
   (run-tests cookie-value-tests)
-  (run-tests p/e-value-tests))
+  (run-tests cookie-value-prop-tests)
+  (run-tests p/e-value-tests)
+  (run-tests p/e-value-prop-tests))
 
 (define-syntax test-cookie-pred
   (syntax-rules (valid invalid)
@@ -33,16 +38,130 @@
              ",,,,,chameleon" "this;that" "this:that" "[bracketed]" "{braced}"
              "slashed/" "back\\slashed" "what?" "x=y" "spaced out" "\ttabbed")))
 
+;; Excludes CTLs (0-31, 127) by default.
+(define (gen:ascii-char exceptions [lo 32] [hi 127])
+  (apply
+   gen:choice
+   (for*/list ([code (in-range lo hi)]
+               [char (in-value (integer->char code))]
+               #:unless (memv char exceptions))
+     (gen:const char))))
+
+(define separator-chars
+  '(#\( #\) #\< #\> #\@
+    #\, #\; #\: #\\ #\"
+    #\/ #\[ #\] #\? #\=
+    #\{ #\} #\space #\tab))
+(define separator-octets
+  (map char->integer separator-chars))
+(define gen:token
+  (gen:ascii-char separator-chars))
+
+(define gen:cookie-name
+  (gen:let ([t0 gen:token]
+            [ts (gen:list gen:token)])
+    (apply string t0 ts)))
+
+(define gen:invalid-cookie-name
+  (gen:string
+   (gen:ascii-char
+    (for/list ([i (in-range 32 127)]
+               #:unless (memv i separator-octets))
+      (integer->char i))
+    0 128)))
+
+(define-test-suite cookie-name-prop-tests
+  (test-case "cookie-name? property tests (valid)"
+    (check-property
+     (property ([name gen:cookie-name])
+       (check-true (cookie-name? name)))))
+  (test-case "cookie-name? property tests (invalid)"
+    (check-property
+     (property ([name gen:invalid-cookie-name])
+       (check-false (cookie-name? name))))))
+
 (define-test-suite cookie-value-tests
   (test-cookie-pred "cookie values" cookie-value? #t
     (valid "value" "(" "!" ")" ")!" "(!" "(!)" "!)" "\"hey!\"" "a=b=c" "`a")
     (invalid "a;b" "a,b" "a b" "a\tb" "a=\"foo\"")))
 
+;; cookie-octet      = %x21 / %x23-2B / %x2D-3A / %x3C-5B / %x5D-7E
+;;                       ; US-ASCII characters excluding CTLs,
+;;                       ; whitespace DQUOTE, comma, semicolon,
+;;                       ; and backslash
+(define valid-cookie-octets
+  (append '(#x21)
+          (range #x23 (add1 #x2B))
+          (range #x2D (add1 #x3A))
+          (range #x3C (add1 #x5B))
+          (range #x5D (add1 #x7E))))
+
+(define gen:cookie-octet
+  (apply gen:choice (map (compose1 gen:const integer->char) valid-cookie-octets)))
+
+(define gen:cookie-value
+  (gen:choice
+   (gen:string gen:cookie-octet)
+   (gen:let ([value (gen:string gen:cookie-octet)])
+     (string-append "\"" value "\""))))
+
+(define gen:invalid-cookie-octet
+  (apply
+   gen:choice
+   (for/list ([i (in-range 0 128)]
+              #:unless (memv i valid-cookie-octets))
+     (gen:const (integer->char i)))))
+
+(define gen:invalid-cookie-value
+  (gen:let ([o0 gen:invalid-cookie-octet]
+            [os (gen:string gen:invalid-cookie-octet)])
+    (string-append (string o0) os)))
+
+(define-test-suite cookie-value-prop-tests
+  (test-case "cookie-value? property tests (valid)"
+    (check-property
+     (property ([value gen:cookie-value])
+       (check-true (cookie-value? value)))))
+  (test-case "cookie-value? property tests (invalid)"
+    (check-property
+     (property ([value gen:invalid-cookie-value])
+       (check-false (cookie-value? value))))))
+
 (define-test-suite p/e-value-tests
   (test-cookie-pred "path/extension values" path/extension-value? #f
     (valid "abc=123"
            "def=(define (forever x) (forever x))"
            "You're so \"cool\"")
     (invalid "x;y" "\000" (string #\rubout))))
 
+(define av-octet-exception-chars
+  '(#\# #\\ #\;))
+(define av-octet-exception-octets
+  (map char->integer av-octet-exception-chars))
+(define gen:av-octet
+  (gen:ascii-char av-octet-exception-chars))
+(define gen:invalid-av-octet
+  (gen:ascii-char
+   (for/list ([i (in-range 32 127)]
+              #:unless (memv i av-octet-exception-octets))
+     (integer->char i))
+   0 127))
+
+(define gen:p/e-value
+  (gen:string gen:av-octet))
+(define gen:invalid-p/e-value
+  (gen:let ([o0 gen:invalid-av-octet]
+            [os (gen:string gen:invalid-av-octet)])
+    (string-append (string o0) os)))
+
+(define-test-suite p/e-value-prop-tests
+  (test-case "path/extension-value? property tests (valid)"
+    (check-property
+     (property ([p/e gen:p/e-value])
+       (check-true (path/extension-value? p/e)))))
+  (test-case "path/extension-value? property tests (invalid)"
+    (check-property
+     (property ([p/e gen:invalid-p/e-value])
+       (check-false (path/extension-value? p/e))))))
+
 (module+ test (require (submod ".." main))) ; for raco test & drdr

net-cookies-test/tests/net/cookies/server.rkt

@@ -2,7 +2,9 @@
 
 (require net/cookies/server
          (submod net/cookies/server private)
+         (only-in net/cookies/user-agent parse-date)
          racket/date
+         rackcheck
          rackunit)
 
 ;; Based on tests from original net/cookie (JBM, 2006-12-01)
@@ -186,17 +188,30 @@
   (contract-test (make-cookie "x" "y" #:domain ".bad-domain;com")))
 
 (define-test-suite date-tests
-  (let ([table '(((1992  5 29 23 59  9) "Fri, 29 May 1992 23:59:09 GMT")
-                 ((1992  2 29 10  0 30) "Sat, 29 Feb 1992 10:00:30 GMT")
-                 ((2023 12 24  9 45  5) "Sun, 24 Dec 2023 09:45:05 GMT")
-                 ((2023 12 27 18 19  0) "Wed, 27 Dec 2023 18:19:00 GMT"))])
-    (for ([test (in-list table)])
-      (define seconds
-        (apply find-seconds
-               (append
-                (reverse (car test))
-                (list #f))))
-      (check-equal?
-       (date->rfc1123-string
-        (seconds->date seconds #f))
-       (cadr test)))))
+  (test-case "example tests"
+    (let ([table '(((1992  5 29 23 59  9) "Fri, 29 May 1992 23:59:09 GMT")
+                   ((1992  2 29 10  0 30) "Sat, 29 Feb 1992 10:00:30 GMT")
+                   ((2023 12 24  9 45  5) "Sun, 24 Dec 2023 09:45:05 GMT")
+                   ((2023 12 27 18 19  0) "Wed, 27 Dec 2023 18:19:00 GMT"))])
+      (for ([test (in-list table)])
+        (define seconds
+          (apply find-seconds
+                 (append
+                  (reverse (car test))
+                  (list #f))))
+        (check-equal?
+         (date->rfc1123-string
+          (seconds->date seconds #f))
+         (cadr test)))))
+
+  (test-case "roundtrip property tests"
+    (define gen:date
+      (gen:let ([seconds (gen:integer-in 0 (current-seconds))])
+        (seconds->date seconds #f)))
+    (check-property
+     (property ([a-date gen:date])
+       ;; a-date: date*
+       ;; parse-date: string -> date
+       (define seconds (date->seconds a-date #f))
+       (define rt-seconds (date->seconds (parse-date (date->rfc1123-string a-date)) #f))
+       (check-equal? seconds rt-seconds)))))