Changeset 30967 in project


Ignore:
Timestamp:
06/05/14 21:58:43 (6 years ago)
Author:
sjamaan
Message:

uri-generic: fixup packrat alternative due to bitrot (probably it relied on incorrectly leaky macro expansion which got fixed in CHICKEN core)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/uri-generic/trunk/alternatives/uri-generic.packrat.scm

    r20514 r30967  
    44
    55(module uri-generic
    6   (uri-reference update-uri update-authority
     6  (uri-reference make-uri update-uri update-authority
    77   uri-reference? uri-auth uri-authority uri-scheme uri-path uri-query
    88   uri-fragment uri-host uri-port uri-username uri-password
     
    1919   char-set:uri-reserved char-set:uri-unreserved)
    2020
    21 (import chicken scheme extras data-structures ports)
    22 
    23 (require-library regex)
    24 (import irregex)
    25 (require-extension defstruct srfi-1 srfi-4 srfi-13 srfi-14 packrat)
     21(import chicken scheme)
     22(use extras data-structures ports irregex
     23     srfi-1 srfi-4 srfi-13 srfi-14 packrat)
     24
     25
     26(define uri-error error)
     27
     28(cond-expand
     29 (chicken)
     30 (else
     31  (define (->string obj)
     32    (let ((s (open-output-string)))
     33      (display obj s)
     34      (let ((result (get-output-string s)))
     35        (close-output-port s)
     36        result)))
     37  ))
     38
    2639
    2740;; What to do with these?
    28 #;(cond-expand
    29    (utf8-strings (use utf8-srfi-13 utf8-srfi-14))
    30    (else (use srfi-13 srfi-14)))
    31 
    32 (defstruct URI      scheme authority path query fragment)
    33 (defstruct URIAuth  username password host port)
    34 
    35 (define-record-printer (URI x out)
    36   (fprintf out "#(URI scheme=~S authority=~A path=~S query=~S fragment=~S)"
    37            (URI-scheme x)
    38            (URI-authority x)
    39            (URI-path x)
    40            (URI-query x)
    41            (URI-fragment x)))
    42 
    43 (define-record-printer (URIAuth x out)
    44   (fprintf out "#(URIAuth host=~S port=~A)"
    45            (URIAuth-host x)
    46            (URIAuth-port x)))
     41;; #;(cond-expand
     42;;    (utf8-strings (use utf8-srfi-13 utf8-srfi-14))
     43;;    (else (use srfi-13 srfi-14)))
     44
     45(define-record-type <URI>
     46  (make-URI scheme authority path query fragment)
     47  URI?
     48  (scheme URI-scheme URI-scheme-set!)
     49  (authority URI-authority URI-authority-set!)
     50  (path URI-path URI-path-set!)
     51  (query URI-query URI-query-set!)
     52  (fragment URI-fragment URI-fragment-set!))
     53
     54(define-record-type <URIAuth>
     55  (make-URIAuth username password host port)
     56  URIAuth?
     57  (username URIAuth-username URIAuth-username-set!)
     58  (password URIAuth-password URIAuth-password-set!)
     59  (host URIAuth-host URIAuth-host-set!)
     60  (port URIAuth-port URIAuth-port-set!))
     61
     62
     63(cond-expand
     64 (chicken
     65  (define-record-printer (<URI> x out)
     66    (fprintf out "#(URI scheme=~S authority=~A path=~S query=~S fragment=~S)"
     67             (URI-scheme x)
     68             (URI-authority x)
     69             (URI-path x)
     70             (URI-query x)
     71             (URI-fragment x)))
     72 
     73  (define-record-printer (<URIAuth> x out)
     74    (fprintf out "#(URIAuth host=~S port=~A)"
     75             (URIAuth-host x)
     76             (URIAuth-port x))))
     77 (else))
     78
     79
     80(define (update-URI uri . args)
     81  (let loop ((args args)
     82             (new-scheme (URI-scheme uri))
     83             (new-authority (URI-authority uri))
     84             (new-path (URI-path uri))
     85             (new-query (URI-query uri))
     86             (new-fragment (URI-fragment uri)))
     87    (cond ((null? args)
     88           (make-URI new-scheme new-authority new-path new-query new-fragment))
     89          ((null? (cdr args))
     90           (uri-error "malformed arguments to update-URI"))
     91          (else
     92           (let ((key (car args))
     93                 (value (cadr args)))
     94             (loop (cddr args)
     95                   (if (eq? key 'scheme) value new-scheme)
     96                   (if (eq? key 'authority) value new-authority)
     97                   (if (eq? key 'path) value new-path)
     98                   (if (eq? key 'query) value new-query)
     99                   (if (eq? key 'fragment) value new-fragment)))))))
     100
     101
     102(define (update-URIAuth uri-auth . args)
     103  (let loop ((args args)
     104             (new-username (URIAuth-username uri-auth))
     105             (new-password (URIAuth-password uri-auth))
     106             (new-host (URIAuth-host uri-auth))
     107             (new-port (URIAuth-port uri-auth)))
     108    (cond ((null? args)
     109           (make-URIAuth new-username new-password new-host new-port))
     110          ((null? (cdr args))
     111           (uri-error "malformed arguments to update-URIAuth"))
     112          (else
     113           (let ((key (car args))
     114                 (value (cadr args)))
     115             (loop (cddr args)
     116                   (if (eq? key 'username) value new-username)
     117                   (if (eq? key 'password) value new-password)
     118                   (if (eq? key 'host) value new-host)
     119                   (if (eq? key 'port) value new-port)))))))
     120
    47121
    48122(define uri-reference? URI?)
     
    79153(define update-authority update-URIAuth)
    80154
    81 (define update-uri
     155(define update-uri*
    82156  (let ((unset (list 'unset)))
    83    (lambda (uri . key/values)
    84      (apply
    85       (lambda (#!key
    86                (scheme (URI-scheme uri)) (path (URI-path uri))
    87                (query (URI-query uri)) (fragment (URI-fragment uri))
    88                (auth unset) (authority unset))
     157    (lambda (uri . args)
     158      (let loop ((key/values args)
     159                 (scheme (URI-scheme uri))
     160                 (path (URI-path uri))
     161                 (query (URI-query uri))
     162                 (fragment (URI-fragment uri))
     163                 (auth unset)
     164                 (authority unset))
     165        (cond
     166         ((null? key/values)
    89167        (let* ((base-auth (or
    90168                           (cond
     
    92170                            ((not (eq? unset authority)) authority)
    93171                            (else (URI-authority uri)))
    94                            (make-URIAuth)))
    95                (updated-auth (apply update-authority base-auth key/values))
    96                (final-auth (if (equal? (make-URIAuth) updated-auth)
     172                             (make-URIAuth #f #f #f #f)))
     173                 (updated-auth (apply update-authority base-auth args))
     174                 (final-auth (if (uri-auth-equal? (make-URIAuth #f #f #f #f)
     175                                                  updated-auth)
    97176                               #f
    98177                               updated-auth)))
    99           (make-URI scheme: scheme path: path query: query fragment: fragment
    100                     authority: final-auth))) key/values))))
     178            (make-URI scheme final-auth path query fragment)))
     179         ((null? (cdr key/values))
     180          (uri-error "malformed arguments to update-uri"))
     181         ((not (memq (car key/values)
     182                     '(scheme authority path query fragment
     183                              username password host port)))
     184          (uri-error "unknown argument to update-uri" (car key/values)))
     185         (else
     186          (let ((key (car key/values))
     187                (value (cadr key/values)))
     188            (loop (cddr key/values)
     189                  (if (eq? key 'scheme) value scheme)
     190                  (if (eq? key 'path) value path)
     191                  (if (eq? key 'query) value query)
     192                  (if (eq? key 'fragment) value fragment)
     193                  (if (eq? key 'auth) value auth)
     194                  (if (eq? key 'authority) value authority)))))))))
     195
     196
     197(cond-expand
     198
     199 (chicken
     200  (define update-uri
     201    (let ((unset (list 'unset)))
     202      (lambda (uri . key/values)
     203        (apply
     204         (lambda (#!key
     205                  (scheme (URI-scheme uri)) (path (URI-path uri))
     206                  (query (URI-query uri)) (fragment (URI-fragment uri))
     207                  (auth unset) (authority unset)
     208                  (username unset) (password unset)
     209                  (host unset) (port unset))
     210           (let* ((args (list 'scheme scheme
     211                              'path path
     212                              'query query
     213                              'fragment fragment))
     214                  (args (if (not (eq? auth unset))
     215                            (append args (list 'auth auth)) args))
     216                  (args (if (not (eq? authority unset))
     217                            (append args (list 'authority authority)) args))
     218                  (args (if (not (eq? username unset))
     219                            (append args (list 'username username)) args))
     220                  (args (if (not (eq? password unset))
     221                            (append args (list 'password password)) args))
     222                  (args (if (not (eq? host unset))
     223                            (append args (list 'host host)) args))
     224                  (args (if (not (eq? port unset))
     225                            (append args (list 'port port)) args))
     226                  )
     227             (apply update-uri* uri args)))
     228         key/values)))))
     229
     230 (else
     231  (define update-uri update-uri*)))
     232
     233
     234(define (make-uri* . key/values)
     235  (apply update-uri* (make-URI #f #f '() #f #f) key/values))
     236
     237(cond-expand
     238
     239 (chicken
     240  (define (make-uri . key/values)
     241    (apply update-uri (make-URI #f #f '() #f #f) key/values)))
     242 
     243 (else
     244  (define make-uri make-uri*)))
     245
     246
     247(define (uri-equal? a b)
     248  (or (and (not a) (not b))
     249      (and (equal? (URI-scheme a) (URI-scheme b))
     250           (uri-auth-equal? (URI-authority a) (URI-authority b))
     251           (equal? (URI-path a) (URI-path b))
     252           (equal? (URI-query a) (URI-query b))
     253           (equal? (URI-fragment a) (URI-fragment b)))))
     254
     255
     256(define (uri-auth-equal? a b)
     257  (or (and (not a) (not b))
     258      (and
     259       (equal? (URIAuth-username a) (URIAuth-username b))
     260       (equal? (URIAuth-password a) (URIAuth-password b))
     261       (equal? (URIAuth-host a) (URIAuth-host b))
     262       (equal? (URIAuth-port a) (URIAuth-port b)))))
    101263
    102264
     
    109271(define (absolute-uri? u)
    110272  (and (uri-reference? u) (not (relative-ref? u)) (not (uri-fragment u))))
    111 
    112273
    113274;; RFC3986, section 2.2
     
    231392         (scheme         (string->symbol (string-downcase (->string (uri-scheme uri)))))
    232393         (host           (normalize-pct-encoding (string-downcase (uri-host uri)))))
    233     (update-uri normalized-uri scheme: scheme host: host)))
     394    (update-uri* normalized-uri 'scheme scheme 'host host)))
    234395
    235396;; RFC 3986, section 2.1
     
    283444                              (uri-decode-string s path-safe-chars))
    284445                            (string-split rp "/" #t))))))
    285    (make-URI scheme: (handle-exceptions
    286                          exn #f
    287                          (and-let* ((s (irregex-match-substring m 'scheme)))
    288                            (string->symbol s)))
    289              authority: (let ((user (irregex-match-substring m 'username))
    290                               (pass (irregex-match-substring m 'password))
    291                               (host (irregex-match-substring m 'host))
    292                               (port (irregex-match-substring m 'port)))
    293                           (and (or user pass host port)
    294                                (make-URIAuth
    295                                 username: user password: pass
    296                                 host: host
    297                                 port: (and port (string->number port)))))
    298              path: path
    299              query: (irregex-match-substring m 'query)
    300              fragment: (irregex-match-substring m 'fragment))))
     446   (make-URI (handle-exceptions
     447                 exn #f
     448               (and-let* ((s (irregex-match-substring m 'scheme)))
     449                 (string->symbol s)))
     450             (let ((user (irregex-match-substring m 'username))
     451                   (pass (irregex-match-substring m 'password))
     452                   (host (irregex-match-substring m 'host))
     453                   (port (irregex-match-substring m 'port)))
     454               (and (or user pass host port)
     455                    (make-URIAuth
     456                     user pass host (and port (string->number port)))))
     457             path
     458             (irregex-match-substring m 'query)
     459             (irregex-match-substring m 'fragment))))
    301460
    302461;; RFC3986, section 3.2.2
     
    334493    (if (char-set-contains? char-set dc) (list dc) pct-list)))
    335494
    336 (define uri-parser
     495(define uri-reference-parser
    337496  (packrat-parser
    338    uri
     497   uri-reference
    339498   
    340499   (pct-encoded (('#\% h1 <- hex-digit h2 <- hex-digit) `(#\% ,h1 ,h2)))
     
    487646                (() #f))
    488647   (authority ((ui <- userinfo@? h <- host p <- :port?)
    489                (make-URIAuth
    490                 port: p host: h username: (car ui) password: (cdr ui))))
     648               (make-URIAuth (car ui) (cdr ui) h p)))
    491649
    492650   ;; RFC3986, section 3
     
    591749               (() #f))
    592750   (uri ((s <- scheme '#\: h <- hier-part q <- ?-query? f <- hash-fragment? eof)
    593          (make-URI scheme: s authority: (alist-ref 'auth h)
    594                    path: (alist-ref 'path h) query: q fragment: f)))))
    595 
    596 ;;  RFC3986, section 4.2
    597 ;;
    598 ;;   relative-ref  = relative-part [ "?" query ] [ "#" fragment ]
    599 ;;
    600 ;;   relative-part = "//" authority path-abempty
    601 ;;                 / path-absolute
    602 ;;                 / path-noscheme
    603 ;;                 / path-empty
    604 (define relative-ref-parser
    605   (packrat-parser
    606    relative-ref
     751         (make-URI s (alist-ref 'auth h) (alist-ref 'path h) q f)))
     752
     753   ;;  RFC3986, section 4.2
     754   ;;
     755   ;;   relative-ref  = relative-part [ "?" query ] [ "#" fragment ]
     756   ;;
     757   ;;   relative-part = "//" authority path-abempty
     758   ;;                 / path-absolute
     759   ;;                 / path-noscheme
     760   ;;                 / path-empty
    607761   (relative-part (('#\/ '#\/ a <- authority p <- path-abempty) `(,a . ,p))
    608762                  ((p <- path-absolute) `(#f . ,p))
     
    610764                  ((p <- path-empty) `(#f . ,p)))
    611765   (relative-ref ((rp <- relative-part q <- ?-query? f <- hash-fragment? eof)
    612                   (make-URI scheme: #f authority: (car rp) path: (cdr rp)
    613                             query: q fragment: f)))))
     766                  (make-URI #f (car rp) (cdr rp) q f)))
     767
     768   (uri-reference ((u <- uri) u)
     769                  ((r <- relative-ref) r))))
    614770
    615771;;  Reference, Relative and Absolute URI forms
     
    635791
    636792(define (uri-reference s)
    637   (or (parse-string uri-parser s)
    638       (parse-string relative-ref-parser s)))
     793  (parse-string uri-reference-parser s))
    639794
    640795;; RFC3986, section 4.3
     
    667822  (and (uri-reference? ref) (uri-reference? base)
    668823       (cond ((uri-scheme ref)      (update-URI ref
    669                                                 path: (just-segments ref)))
     824                                                'path (just-segments ref)))
    670825             ((uri-authority ref)   (update-URI ref
    671                                                 path: (just-segments ref)
    672                                                 scheme: (uri-scheme base)))
     826                                                'path (just-segments ref)
     827                                                'scheme (uri-scheme base)))
    673828             ((let ((p (uri-path ref))) (and (not (null? p)) p)) =>
    674829              (lambda (ref-path)
    675830                (if (and (pair? ref-path) (eq? '/ (car ref-path)))
    676831                    (update-URI ref
    677                                 scheme: (uri-scheme base)
    678                                 authority: (uri-auth base)
    679                                 path: (just-segments ref))
     832                                'scheme (uri-scheme base)
     833                                'authority (uri-auth base)
     834                                'path (just-segments ref))
    680835                    (update-URI ref
    681                                 scheme: (uri-scheme base)
    682                                 authority: (uri-auth base)
    683                                 path: (merge-paths base ref-path)))))
     836                                'scheme (uri-scheme base)
     837                                'authority (uri-auth base)
     838                                'path (merge-paths base ref-path)))))
    684839             ((uri-query ref) (update-URI ref
    685                                           scheme: (uri-scheme base)
    686                                           authority: (uri-auth base)
    687                                           path: (merge-paths base (list ""))))
     840                                          'scheme (uri-scheme base)
     841                                          'authority (uri-auth base)
     842                                          'path (merge-paths base (list ""))))
    688843             (else (update-URI ref
    689                                path: (URI-path base)
    690                                scheme: (URI-scheme base)
    691                                authority: (URI-authority base)
    692                                query: (URI-query base))))))
     844                               'path (URI-path base)
     845                               'scheme (URI-scheme base)
     846                               'authority (URI-authority base)
     847                               'query (URI-query base))))))
    693848
    694849;;
     
    711866(define (uri-relative-from uabs base)
    712867  (cond ((ucdiff? uri-scheme uabs base)      (update-URI uabs))
    713         ((ucdiff? uri-authority uabs base)   (update-URI uabs scheme: #f))
     868        ((ucdiff? uri-authority uabs base)   (update-URI uabs 'scheme #f))
    714869        ;; Special case: no relative representation for http://a/ -> http://a
    715870        ;; ....unless that should be a path of ("..")
    716         ((null? (uri-path uabs))             (update-URI uabs scheme: #f))
     871        ((null? (uri-path uabs))             (update-URI uabs 'scheme #f))
    717872        ((ucdiff? uri-path uabs base)
    718873         (update-URI uabs
    719                      scheme: #f
    720                      authority: #f
    721                      path: (rel-path-from
     874                     'scheme #f
     875                     'authority #f
     876                     'path (rel-path-from
    722877                            (remove-dot-segments (uri-path uabs))
    723878                            (remove-dot-segments (uri-path base)))))
    724879        ((ucdiff? uri-query uabs base)
    725880         (update-URI uabs
    726                      scheme: #f
    727                      authority: #f
    728                      path: (list)))
     881                     'scheme #f
     882                     'authority #f
     883                     'path (list)))
    729884        (else
    730885         (update-URI uabs
    731                      scheme: #f
    732                      authority: #f
    733                      query: #f
    734                      path: (list)))))
     886                     'scheme #f
     887                     'authority #f
     888                     'query #f
     889                     'path (list)))))
    735890
    736891(define (ucdiff? sel u1 u2)
     
    798953
    799954(define (uri-normalize-path-segments uri)
    800   (update-URI uri path: (just-segments uri)))
     955  (update-URI uri 'path (just-segments uri)))
    801956
    802957(define (merge0 pb pr)
Note: See TracChangeset for help on using the changeset viewer.