Changeset 36555 in project


Ignore:
Timestamp:
09/08/18 15:17:32 (2 months ago)
Author:
sjamaan
Message:

Port uri-generic comparse alternative to CHICKEN 5 and fix several bugs while at it

Turns out the IPv6 matcher was completely busted, and hard to fix due
to local ambiguities.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/5/uri-generic/trunk/alternatives/uri-generic.comparse.scm

    r36551 r36555  
    11;; uri-generic version based on comparse
    2 
    3 (provide 'uri-generic)
    42
    53(module uri-generic
    64  (uri-reference make-uri update-uri update-authority
    75   uri-reference? uri-auth uri-authority uri-scheme uri-path uri-query
    8    uri-fragment uri-host uri-port uri-username uri-password
    9    authority? authority-host authority-port
     6   uri-fragment uri-host uri-ipv6-host? uri-port
     7   uri-username uri-password
     8   authority? authority-host authority-ipv6-host? authority-port
    109   authority-username authority-password
    1110   
     
    1918   char-set:uri-reserved char-set:uri-unreserved)
    2019
    21 (import chicken scheme)
    22 
    23 (use extras data-structures ports comparse
    24      srfi-1 srfi-4 srfi-13 srfi-14)
     20(import scheme (chicken base) (chicken string) (chicken port)
     21        (chicken format) srfi-14 comparse)
    2522
    2623(define uri-error error)
     
    5249
    5350(define-record-type <URIAuth>
    54   (make-URIAuth username password host port)
     51  (make-URIAuth username password host ipv6-host? port)
    5552  URIAuth?
    5653  (username URIAuth-username URIAuth-username-set!)
    5754  (password URIAuth-password URIAuth-password-set!)
    5855  (host URIAuth-host URIAuth-host-set!)
     56  (ipv6-host? URIAuth-ipv6-host? URIAuth-ipv6-host?-set!)
    5957  (port URIAuth-port URIAuth-port-set!))
    6058
     
    7068 
    7169  (define-record-printer (<URIAuth> x out)
    72     (fprintf out "#(URIAuth host=~S port=~A)"
     70    (fprintf out "#(URIAuth host=~S~A port=~A)"
    7371             (URIAuth-host x)
     72             (if (URIAuth-ipv6-host? x) "(ipv6)" "")
    7473             (URIAuth-port x))))
    7574 (else))
     
    9796
    9897
     98(define (is-ipv6-host? h) (and (substring-index ":" h) #t))
     99
    99100(define (update-URIAuth uri-auth . args)
    100101  (let loop ((args args)
     
    102103             (new-password (URIAuth-password uri-auth))
    103104             (new-host (URIAuth-host uri-auth))
     105             (new-ipv6-host? (URIAuth-ipv6-host? uri-auth))
    104106             (new-port (URIAuth-port uri-auth)))
    105107    (cond ((null? args)
    106            (make-URIAuth new-username new-password new-host new-port))
     108           (make-URIAuth new-username new-password
     109                         new-host new-ipv6-host? new-port))
    107110          ((null? (cdr args))
    108111           (uri-error "malformed arguments to update-URIAuth"))
     
    114117                   (if (eq? key 'password) value new-password)
    115118                   (if (eq? key 'host) value new-host)
     119                   (if (eq? key 'host)
     120                       (is-ipv6-host? value)
     121                       new-ipv6-host?)
    116122                   (if (eq? key 'port) value new-port)))))))
    117123
     
    130136    (and auth (URIAuth-host auth))))
    131137
     138(define (uri-ipv6-host? x)
     139  (let ((auth (URI-authority x)))
     140    (and auth (URIAuth-ipv6-host? auth))))
     141
    132142(define (uri-port x)
    133143  (let ((auth (URI-authority x)))
     
    144154(define authority? URIAuth?)
    145155(define authority-host URIAuth-host)
     156(define authority-ipv6-host? URIAuth-ipv6-host?)
    146157(define authority-port URIAuth-port)
    147158(define authority-username URIAuth-username)
     
    167178                            ((not (eq? unset authority)) authority)
    168179                            (else (URI-authority uri)))
    169                              (make-URIAuth #f #f #f #f)))
     180                             (make-URIAuth #f #f #f #f #f)))
    170181                 (updated-auth (apply update-authority base-auth args))
    171                  (final-auth (if (uri-auth-equal? (make-URIAuth #f #f #f #f)
     182                 (final-auth (if (uri-auth-equal? (make-URIAuth #f #f #f #f #f)
    172183                                                  updated-auth)
    173184                               #f
     
    306317;;
    307318
    308 (define (uri->string uri . rest)
    309   (let-optionals rest ((userinfomap (lambda (u pw) (string-append u ":******" ))))
    310     (with-output-to-string
    311       (lambda ()
    312         (display-fragments
    313          `(,(and-let* ((scheme (uri-scheme uri))) (list scheme ":"))
    314            ,(and-let* ((auth (URI-authority uri))
    315                        (host (URIAuth-host auth)))
    316               (let ((username (URIAuth-username auth)))
    317                 (list "//" (and username (list (userinfomap username (URIAuth-password auth)) "@"))
    318                       host (and (URIAuth-port auth)
    319                                 (list ":" (URIAuth-port auth))))))
    320            ,(path->string (uri-path uri))
    321            ,(and-let* ((query (uri-query uri))) (list "?" query))
    322            ,(and-let* ((fragment (uri-fragment uri))) (list  "#" fragment))))))))
     319(define (uri->string uri . maybe-userinfomap)
     320  (let ((userinfomap (if (pair? maybe-userinfomap)
     321                         (car maybe-userinfomap)
     322                         (lambda (u pw)
     323                           (string-append u ":******" )))))
     324    (cond ((URI? uri)
     325            (with-output-to-string
     326              (lambda ()
     327               (let ((scheme (URI-scheme uri))
     328                     (authority (URI-authority uri))
     329                     (path (URI-path uri))
     330                     (query (URI-query uri))
     331                     (fragment (URI-fragment uri)))
     332                (display-fragments
     333                  (list
     334                   (and scheme (list scheme ":"))
     335                   (and (URIAuth? authority)
     336                        (string? (URIAuth-host authority))
     337                        (let ((username (URIAuth-username authority))
     338                              (password (URIAuth-password authority))
     339                              (host (URIAuth-host authority))
     340                              (ipv6? (URIAuth-ipv6-host? authority))
     341                              (port (URIAuth-port authority)))
     342                          (list "//" (and username (list (userinfomap
     343                                                          username
     344                                                          password) "@"))
     345                                (if ipv6? "[" "") host (if ipv6? "]" "")
     346                                (and port (list ":" port)))))
     347                   (path->string path)
     348                   (and query (list "?" query))
     349                   (and fragment (list  "#" fragment))))))))
     350           (else #f))))
    323351
    324352
     
    419447     `(#\% ,(hex-digit (quotient i 16)) ,(hex-digit (remainder i 16)))))
    420448  (list->string
    421    (string-fold-right (lambda (c res)
    422                         (if (char-set-contains? char-set c)
    423                             (append (pct-encode c) res)
    424                             (cons c res)))
    425                       '() str)))
     449   (foldr (lambda (c res)
     450            (if (char-set-contains? char-set c)
     451                (append (pct-encode c) res)
     452                (cons c res)))
     453          '() (string->list str))))
    426454
    427455(define (normalize-pct-encoding str)
     
    438466            (if (char-set-contains? char-set:uri-unreserved decoded)
    439467                (string decoded)
    440                 (string-upcase (string-append pct encoded))))))
     468                (string #\%
     469                        (char-upcase (string-ref encoded 0))
     470                        (char-upcase (string-ref encoded 1)))))))
    441471       item)))
    442472    str)))
     
    459489
    460490(define dec-octet
    461   (any-of numeric
    462           ;; ucs-range->char-set is inclusive lower, exclusive upper bound!
     491  ;; Reordered from RFC's ABNF to avoid nongreedy match on single numeric
     492  (any-of ;; ucs-range->char-set is inclusive lower, exclusive upper bound!
     493          (sequence (char-seq "25") (ucs-range->char-set #x30 #x36))
     494          (sequence (is #\2) (ucs-range->char-set #x30 #x35) numeric)
     495          (sequence (is #\1) numeric numeric)
    463496          (sequence (in (ucs-range->char-set #x31 #x40)) numeric)
    464           (sequence (is #\1) numeric numeric)
    465           (sequence (is #\2) (ucs-range->char-set #x30 #x35) numeric)
    466           (sequence (char-seq "25") (ucs-range->char-set #x30 #x36) numeric)))
     497          numeric))
    467498
    468499(define ipv4-address
    469   (sequence dec-octet (is #\.) dec-octet (is #\.) dec-octet (is #\.)))
     500  (sequence dec-octet (is #\.) dec-octet (is #\.) dec-octet (is #\.) dec-octet))
    470501
    471502;; IPv6address =                                  6( h16 ":" ) ls32
     
    485516;;                   ; 16 bits of address represented in hexadecimal
    486517
    487 (define  h16 (repeated hex-char 4))
     518(define  h16 (repeated hex-char min: 1 max: 4))
    488519(define ls32 (any-of (sequence h16 (is #\:) h16) ipv4-address))
     520
     521;; Negative-lookahead on :: to prevent greedy match
     522(define  h16-colon
     523  (followed-by (sequence h16 (is #\:)) (none-of (is #\:))))
     524
     525;; Like above, we don't want to consume ls32 at the end
     526(define  h16-colon-no-ls32
     527  (followed-by (sequence h16 (is #\:))
     528               (none-of (sequence (sequence (is #\:) h16) (is #\])))))
    489529
    490530(define ipv6-address
    491531  (any-of
    492532   (sequence (repeated (sequence h16 (is #\:)) 6) ls32)
    493    (sequence (char-seq "::") (repeated (sequence h16 (is #\:)) 5) ls32)
     533   (sequence (char-seq "::") (repeated h16-colon-no-ls32 5)
     534             ls32)
    494535   (sequence (maybe h16)
    495              (char-seq "::") (repeated (sequence h16 (is #\:)) 4) ls32)
    496    (sequence (maybe (sequence (repeated (sequence h16 (is #\:)) 1) h16))
    497              (char-seq "::") (repeated (sequence h16 (is #\:)) 3) ls32)
    498    (sequence (maybe (sequence (repeated (sequence h16 (is #\:)) 2) h16))
    499              (char-seq "::") (repeated (sequence h16 (is #\:)) 2) ls32)
    500    (sequence (maybe (sequence (repeated (sequence h16 (is #\:)) 3) h16))
    501              (char-seq "::") (repeated (sequence h16 (is #\:)) 1) ls32)
    502    (sequence (maybe (sequence (repeated (sequence h16 (is #\:)) 4) h16))
     536             (char-seq "::") (repeated h16-colon-no-ls32 4)
     537             ls32)
     538   (sequence (maybe (sequence (repeated h16-colon max: 1) h16))
     539             (char-seq "::") (repeated h16-colon-no-ls32 3)
     540             ls32)
     541   (sequence (maybe (sequence (repeated h16-colon max: 2) h16))
     542             (char-seq "::") (repeated h16-colon-no-ls32 2)
     543             ls32)
     544   (sequence (maybe (sequence (repeated h16-colon max: 3) h16))
     545             (char-seq "::") h16-colon-no-ls32 ls32)
     546   (sequence (maybe (sequence (repeated h16-colon max: 4) h16))
    503547             (char-seq "::") ls32)
    504    (sequence (maybe (sequence (repeated (sequence h16 (is #\:)) 4) h16))
     548   (sequence (maybe (sequence (repeated h16-colon max: 5) h16))
    505549             (char-seq "::") h16)
    506    (sequence (maybe (sequence (repeated (sequence h16 (is #\:)) 4) h16))
     550   (sequence (maybe (sequence (repeated h16-colon max: 6) h16))
    507551             (char-seq "::"))))
    508552
     
    514558;; IP-literal = "[" ( IPv6address / IPvFuture  ) "]"
    515559(define ip-literal
    516   (sequence (is #\[) (any-of ipv6-address ipv-future) (is #\])))
     560  (sequence* ((_ (is #\[))
     561              (address (any-of ipv6-address ipv-future))
     562              (_ (is #\])))
     563             (result address)))
    517564
    518565(define reg-name
     
    564611    (result (make-URIAuth (and ui (alist-ref 'user ui))
    565612                          (and ui (alist-ref 'pass ui))
    566                           host port))))
     613                          host (is-ipv6-host? host) port))))
    567614
    568615;; RFC3986, section 3
Note: See TracChangeset for help on using the changeset viewer.