Changeset 14429 in project


Ignore:
Timestamp:
04/25/09 15:33:28 (11 years ago)
Author:
sjamaan
Message:

Add time parsers, without relying on SRFI-19

Location:
release/4/intarweb/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/intarweb/trunk/header-parsers.scm

    r14361 r14429  
    1111    (max 0.0 (min 1.0 imprecise))))
    1212
    13 ;; TODO: Make this use SRFI-19
    14 (define (rfc822-time-parser str)
    15   0)
     13(foreign-declare "#include <locale.h>")
     14
     15(define setlocale (foreign-lambda c-string setlocale int c-string))
     16
     17(define-foreign-variable LC_TIME int)
     18
     19(define-syntax let-locale
     20  (syntax-rules ()
     21    ((let-locale ((cat val) ...) body ...)
     22     (let ((backup '()))
     23       (dynamic-wind
     24           (lambda () (set! backup '((cat . ,(setlocale cat val)) ...)))
     25           (lambda () body ...)
     26           (lambda () (setlocale cat (alist-ref backup 'cat)) ...))))))
     27
     28(define (rfc1123-string->time str)
     29  (and (string-search "(Sun|Mon|Tue|Wed|Thu|Fri|Sat), [0-9]{2} (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) [0-9]{4} [0-9]{2}:[0-9]{2}:[0-9]{2} GMT" str)
     30       (let-locale ((LC_TIME "POSIX"))
     31                   (string->time str "%a, %d %b %Y %X GMT"))))
     32
     33(define (rfc1123-parser str)
     34  (or (rfc1123-string->time str)
     35      (signal-http-condition "Error parsing RFC 1123 date/time"
     36                             'rfc1123-parser 'value str)))
     37
     38(define (rfc850-string->time str)
     39  (and (string-search "(Sunday|Monday|Tuesday|Wednesday|Thursday|Friday|Saturday), [0-9]{2}-(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)-[0-9]{2} [0-9]{2}:[0-9]{2}:[0-9]{2} GMT" str)
     40      (let-locale ((LC_TIME "POSIX"))
     41                  (string->time str "%a, %d-%b-%y %X GMT"))))
     42
     43(define (rfc850-parser str)
     44  (or (rfc850-string->time str)
     45      (signal-http-condition "Error parsing RFC850 date/time"
     46                             'asctime-parser 'value str)))
     47
     48(define (asctime-string->time str)
     49  (and (string-search "(Sun|Mon|Tue|Wed|Thu|Fri|Sat) (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)  ?[0-9]{1,2} [0-9]{2}:[0-9]{2}:[0-9]{2} [0-9]{4}" str)
     50       (let-locale ((LC_TIME "POSIX"))
     51                   (string->time str "%a %b %d %X %Y"))))
     52
     53(define (asctime-parser str)
     54  (or (asctime-string->time str)
     55      (signal-http-condition "Error parsing asctime() date/time"
     56                             'asctime-parser 'value str)))
    1657
    1758;; Get the raw contents of a header
     
    240281
    241282;; rfc1123-date | rfc850-date | asctime-date
    242 (define http-time-parser rfc822-time-parser)
     283(define (http-time-parser str)
     284  (or (rfc1123-string->time str)
     285      (rfc850-string->time str)
     286      (asctime-string->time str)
     287      (signal-http-condition "Error parsing date/time"
     288                             'http-time-parser 'value str)))
    243289
    244290;; [W/]<string>
     
    281327
    282328;;;; MAJOR TODOs
    283 ;; RFC822/1123 mailbox parser - just strings for now
     329;; RFC1123 mailbox parser - just strings for now
    284330(define mailbox-parser identity)
    285331
     
    287333(define if-range-parser identity)
    288334
    289 ;; Either delta-seconds or RFC822 timestamp
     335;; Either delta-seconds or RFC1123 timestamp
    290336(define (retry-after-parser contents)
    291337  (if (string-match "[ \t]*[0-9]+[ \t]*" contents)
    292338      (natnum-parser contents)
    293       (rfc822-time-parser contents)))
     339      (rfc1123-parser contents)))
    294340
    295341;; Tricky - see 2616 14.45
     
    311357
    312358(define set-cookie-parser
    313   (let ((param-parsers `((expires . ,rfc822-time-parser)
     359  (let ((param-parsers `((expires . ,rfc850-parser)
    314360                         (max-age . ,string->number)
    315361                         (version . ,string->number))))
  • release/4/intarweb/trunk/intarweb.scm

    r14361 r14429  
    4949   request-method request-method-set! request-uri request-uri-set!
    5050   request-headers request-headers-set! request-port request-port-set!
    51    update-request
     51   update-request set-request!
    5252   
    5353   request-parsers read-request request-unparsers write-request read-headers
     
    5959   response-code response-code-set! response-reason response-reason-set!
    6060   response-headers response-headers-set! response-port response-port-set!
    61    update-response
     61   update-response set-response!
    6262   
    6363   write-response response-parsers response-unparsers read-response
     
    7575   )
    7676
    77   (import scheme chicken)
     77  (import scheme chicken foreign)
    7878 
    79   (require-library srfi-1 srfi-13 regex regex-case base64 defstruct uri-common)
     79  (require-library srfi-1 srfi-13 regex regex-case base64 defstruct
     80                   uri-common posix)
    8081
    8182  (import extras ports data-structures
    8283          srfi-1 srfi-13 srfi-14 regex regex-case base64
    83           defstruct uri-common)
     84          defstruct uri-common posix)
    8485
    8586(define read-line-limit (make-parameter 1024)) ; #f if you want no limit
     
    267268     (etag . ,entity-tag-parser)
    268269     (expect . ,(single key/values))
    269      (expires . ,(single rfc822-time-parser))
     270     (expires . ,(single rfc1123-parser))
    270271     (from . ,(multiple mailbox-parser))
    271272     (host . ,(single host-parser))
    272273     (if-match . ,(multiple entity-tag-parser))
    273      (if-modified-since . ,(single rfc822-time-parser))
     274     (if-modified-since . ,(single rfc1123-parser))
    274275     (if-none-match . ,(multiple entity-tag-parser))
    275276     (if-range . ,(multiple if-range-parser))
    276      (if-unmodified-since . ,(single rfc822-time-parser))
    277      (last-modified . ,(single rfc822-time-parser))
     277     (if-unmodified-since . ,(single rfc1123-parser))
     278     (last-modified . ,(single rfc1123-parser))
    278279     (location . ,(single normalized-uri))
    279280     (max-forwards . ,(single natnum-parser))
  • release/4/intarweb/trunk/tests/run.scm

    r13597 r14429  
    180180            (header-value 'content-range headers))))
    181181
    182   ;; XXX SRFI-19!
    183182  (test-group "http-time-parser"
    184183    (let ((headers (test-read-headers "Date: Sun, 06 Nov 1994 08:49:37 GMT")))
    185       (test "RFC822/RFC1123 time"
    186             0
    187             (header-value 'date headers)))
     184      (test "RFC1123 time"
     185            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
     186            (utc-time->seconds (header-value 'date headers))))
    188187    (let ((headers (test-read-headers "Date: Sunday, 06-Nov-94 08:49:37 GMT")))
    189188      (test "RFC850 time"
    190             0
    191             (header-value 'date headers)))
     189            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
     190            (utc-time->seconds (header-value 'date headers))))
    192191    (let ((headers (test-read-headers "Date: Sun Nov  6 08:49:37 1994")))
    193192      (test "asctime time"
    194             0
    195             (header-value 'date headers))))
     193            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
     194            (utc-time->seconds (header-value 'date headers)))))
    196195
    197196  (test-group "normalized-uri"
     
    263262            (get-value (first (header-contents 'set-cookie headers))))
    264263      (test "Old-style cookie expires value"
    265             ;; Should use something like
    266             ;; (string->date foo "~A, ~d-~b-~y ~H:~M:~S ~z") in an "en" locale
    267             0
    268             (get-param 'expires
    269                        (first (header-contents 'set-cookie headers))))
     264            (utc-time->seconds '#(42 23 15 20 6 108 0 309 #f 0))
     265            (utc-time->seconds
     266             (get-param 'expires
     267                        (first (header-contents 'set-cookie headers)))))
    270268      (test "Secure value"
    271269            #t
     
    624622;;    single/multiple discard them? Throw an exception?
    625623;; - Add parsing capability for quoted-pairs inside tokens and comments
    626 ;; - Use SRFI-19
    627624;; - Rethink the auto-chunking stuff. Maybe this should be done at a higher level
    628625;; - Think about a good naming convention to distinguish parsers that accept
Note: See TracChangeset for help on using the changeset viewer.