Changeset 36595 in project


Ignore:
Timestamp:
09/13/18 22:15:56 (2 months ago)
Author:
sjamaan
Message:

uri-generic: Initial port of abnf alternative to CHICKEN 5

Location:
release/5/uri-generic/trunk/alternatives
Files:
2 edited

Legend:

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

    r36551 r36595  
    11;; uri-generic version based on the abnf egg
    2 
    3 ;; Needs lexgen v7.1+ and abnf v7.0+
    4 
    5 (provide 'uri-generic)
    62
    73(module uri-generic
    84  (uri-reference make-uri update-uri update-authority
    95   uri-reference? uri-auth uri-authority uri-scheme uri-path uri-query
    10    uri-fragment uri-host uri-port uri-username uri-password
    11    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
    129   authority-username authority-password
    1310   
     
    2118   char-set:uri-reserved char-set:uri-unreserved)
    2219
    23 (import chicken scheme extras data-structures ports)
    24 
    25 (use extras data-structures ports srfi-1 srfi-4 srfi-13 srfi-14
    26      (prefix lexgen lg:) abnf-charlist abnf abnf-consumers)
     20(import scheme (chicken port) (chicken base) (chicken format)
     21        (chicken string) srfi-1 srfi-4 srfi-14 (prefix lexgen lg:)
     22        abnf abnf-consumers)
    2723
    2824
     
    5652
    5753(define-record-type <URIAuth>
    58   (make-URIAuth username password host port)
     54  (make-URIAuth username password host ipv6-host? port)
    5955  URIAuth?
    6056  (username URIAuth-username URIAuth-username-set!)
    6157  (password URIAuth-password URIAuth-password-set!)
    6258  (host URIAuth-host URIAuth-host-set!)
     59  (ipv6-host? URIAuth-ipv6-host? URIAuth-ipv6-host?-set!)
    6360  (port URIAuth-port URIAuth-port-set!))
    6461
     
    7572 
    7673  (define-record-printer (<URIAuth> x out)
    77     (fprintf out "#(URIAuth host=~S port=~A)"
     74    (fprintf out "#(URIAuth host=~S~A port=~A)"
    7875             (URIAuth-host x)
     76             (if (URIAuth-ipv6-host? x) "(ipv6)" "")
    7977             (URIAuth-port x))))
    8078 (else))
     
    103101
    104102
     103(define (is-ipv6-host? h) (and (substring-index ":" h) #t))
     104
    105105(define (update-URIAuth uri-auth . args)
    106106  (let loop ((args args)
     
    108108             (new-password (URIAuth-password uri-auth))
    109109             (new-host (URIAuth-host uri-auth))
     110             (new-ipv6-host? (URIAuth-ipv6-host? uri-auth))
    110111             (new-port (URIAuth-port uri-auth)))
    111112    (cond ((null? args)
    112            (make-URIAuth new-username new-password new-host new-port))
     113           (make-URIAuth new-username new-password
     114                         new-host new-ipv6-host? new-port))
    113115          ((null? (cdr args))
    114116           (uri-error "malformed arguments to update-URIAuth"))
     
    120122                   (if (eq? key 'password) value new-password)
    121123                   (if (eq? key 'host) value new-host)
     124                   (if (eq? key 'host)
     125                       (and value (is-ipv6-host? value))
     126                       new-ipv6-host?)
    122127                   (if (eq? key 'port) value new-port)))))))
    123128
     
    136141    (and auth (URIAuth-host auth))))
    137142
     143(define (uri-ipv6-host? x)
     144  (let ((auth (URI-authority x)))
     145    (and auth (URIAuth-ipv6-host? auth))))
     146
    138147(define (uri-port x)
    139148  (let ((auth (URI-authority x)))
     
    150159(define authority? URIAuth?)
    151160(define authority-host URIAuth-host)
     161(define authority-ipv6-host? URIAuth-ipv6-host?)
    152162(define authority-port URIAuth-port)
    153163(define authority-username URIAuth-username)
     
    173183                            ((not (eq? unset authority)) authority)
    174184                            (else (URI-authority uri)))
    175                              (make-URIAuth #f #f #f #f)))
     185                             (make-URIAuth #f #f #f #f #f)))
    176186                 (updated-auth (apply update-authority base-auth args))
    177                  (final-auth (if (uri-auth-equal? (make-URIAuth #f #f #f #f)
     187                 (final-auth (if (uri-auth-equal? (make-URIAuth #f #f #f #f #f)
    178188                                                  updated-auth)
    179189                               #f
     
    314324;;
    315325
    316 (define (uri->string uri . rest)
    317   (let-optionals rest ((userinfomap (lambda (u pw) (string-append u ":******" ))))
    318     (with-output-to-string
    319       (lambda ()
    320         (display-fragments
    321          `(,(and-let* ((scheme (uri-scheme uri))) (list scheme ":"))
    322            ,(and-let* ((auth (URI-authority uri))
    323                        (host (URIAuth-host auth)))
    324               (let ((username (URIAuth-username auth)))
    325                 (list "//" (and username (list (userinfomap username (URIAuth-password auth)) "@"))
    326                       host (and (URIAuth-port auth)
    327                                 (list ":" (URIAuth-port auth))))))
    328            ,(path->string (uri-path uri))
    329            ,(and-let* ((query (uri-query uri))) (list "?" query))
    330            ,(and-let* ((fragment (uri-fragment uri))) (list  "#" fragment))))))))
     326(define (uri->string uri . maybe-userinfomap)
     327  (let ((userinfomap (if (pair? maybe-userinfomap)
     328                         (car maybe-userinfomap)
     329                         (lambda (u pw)
     330                           (string-append u ":******" )))))
     331    (cond ((URI? uri)
     332            (with-output-to-string
     333              (lambda ()
     334               (let ((scheme (URI-scheme uri))
     335                     (authority (URI-authority uri))
     336                     (path (URI-path uri))
     337                     (query (URI-query uri))
     338                     (fragment (URI-fragment uri)))
     339                (display-fragments
     340                  (list
     341                   (and scheme (list scheme ":"))
     342                   (and (URIAuth? authority)
     343                        (string? (URIAuth-host authority))
     344                        (let ((username (URIAuth-username authority))
     345                              (password (URIAuth-password authority))
     346                              (host (URIAuth-host authority))
     347                              (ipv6? (URIAuth-ipv6-host? authority))
     348                              (port (URIAuth-port authority)))
     349                          (list "//" (and username (list (userinfomap
     350                                                          username
     351                                                          password) "@"))
     352                                (if ipv6? "[" "") host (if ipv6? "]" "")
     353                                (and port (list ":" port)))))
     354                   (path->string path)
     355                   (and query (list "?" query))
     356                   (and fragment (list  "#" fragment))))))))
     357           (else #f))))
    331358
    332359(define uri-decode-string
     
    336363              (lambda (contents)
    337364                (let* ((encoded (car (consumed-chars->string contents)))
    338                        (decoded (integer->char (string->number (string-drop encoded 1) 16))))
     365                       (decoded (integer->char (string->number (substring encoded 1) 16))))
    339366                  (if (char-set-contains? char-set decoded)
    340367                      (list (string decoded))
     
    350377             (res (lg:lex partially-encoded
    351378                          (constantly #f) str)))
    352         (and res (string-concatenate (car res)))))))
     379        (and res (apply string-append (car res)))))))
    353380
    354381(define (display-fragments b)
     
    429456     `(#\% ,(hex-digit (quotient i 16)) ,(hex-digit (remainder i 16)))))
    430457  (list->string
    431    (string-fold-right (lambda (c res)
    432                         (if (char-set-contains? char-set c)
    433                             (append (pct-encode c) res)
    434                             (cons c res)))
    435                       '() str)))
     458   (foldr (lambda (c res)
     459            (if (char-set-contains? char-set c)
     460                (append (pct-encode c) res)
     461                (cons c res)))
     462          '() (string->list str))))
    436463
    437464(define normalize-pct-encoding
     
    440467          (lambda (contents)
    441468            (let* ((encoded (car (consumed-chars->string contents)))
    442                    (decoded (integer->char (string->number (string-drop encoded 1) 16))))
     469                   (decoded (integer->char (string->number (substring encoded 1) 16))))
    443470              (if (char-set-contains? char-set:uri-unreserved decoded)
    444471                  (list (string decoded))
    445                   (list (string-upcase encoded))))))
     472                  (list (list->string (map char-upcase (string->list encoded))))))))
    446473         (escaped-char (bind* decode
    447474                              (concatenation
     
    454481    (lambda (str)
    455482      (and-let* ((res (lg:lex partially-encoded (constantly #f) str)))
    456         (string-concatenate (car res))))))
     483        (apply string-append (car res))))))
    457484
    458485(define (alist->uri contents)
     
    463490                  (port (alist-ref 'port contents)))
    464491              (and (or user pass host port)
    465                    (make-URIAuth user pass host port)))
     492                   (make-URIAuth user pass host
     493                                 (and host (is-ipv6-host? host)) port)))
    466494            (alist-ref 'path contents)
    467495            (alist-ref 'query contents)
     
    494522
    495523(define dec-octet
     524  ;; Reordered from RFC's ABNF to avoid nongreedy match on single numeric
    496525  (alternatives
    497    decimal
    498    (concatenation (range (integer->char #x31) (integer->char #x39))
    499                   decimal)
    500    (concatenation (char #\1) decimal decimal)
     526   (concatenation (char #\2) (char #\5)
     527                  (range (integer->char #x30) (integer->char #x35)))
    501528   (concatenation (char #\2)
    502529                  (range (integer->char #x30) (integer->char #x34))
    503530                  decimal)
    504    (concatenation (char #\2) (char #\5)
    505                   (range (integer->char #x30) (integer->char #x35)))))
     531   (concatenation (char #\1) decimal decimal)
     532   (concatenation (range (integer->char #x31) (integer->char #x39))
     533                  decimal)
     534   decimal))
    506535
    507536(define ipv4-address
     
    525554;;                   ; 16 bits of address represented in hexadecimal
    526555
    527 (define h16 (repetition-n 4 hexadecimal))
     556(define h16 (variable-repetition 1 4 hexadecimal))
    528557(define ls32 (alternatives (concatenation h16 (char #\:) h16) ipv4-address))
    529558
     
    536565                  (repetition-n 4 (concatenation h16 (char #\:))) ls32)
    537566   (concatenation (optional-sequence
    538                    (repetition-n 1 (concatenation h16 (char #\:))))
     567                   (concatenation
     568                    (variable-repetition 0 1 (concatenation h16 (char #\:)))
     569                    h16))
    539570                  (lit "::")
    540571                  (repetition-n 3 (concatenation h16 (char #\:))) ls32)
    541572   (concatenation (optional-sequence
    542                    (repetition-n 2 (concatenation h16 (char #\:))))
     573                   (concatenation
     574                    (variable-repetition 0 2 (concatenation h16 (char #\:)))
     575                    h16))
    543576                  (lit "::")
    544577                  (repetition-n 2 (concatenation h16 (char #\:))) ls32)
    545578   (concatenation (optional-sequence
    546                    (repetition-n 3 (concatenation h16 (char #\:))))
     579                   (concatenation
     580                    (variable-repetition 0 3 (concatenation h16 (char #\:)))
     581                    h16))
    547582                  (lit "::")
    548583                  (concatenation h16 (char #\:)) ls32)
    549584   (concatenation (optional-sequence
    550                    (repetition-n 4 (concatenation h16 (char #\:))))
     585                   (concatenation
     586                    (variable-repetition 0 4 (concatenation h16 (char #\:)))
     587                    h16))
    551588                  (lit "::")
    552589                  ls32)
    553590   (concatenation (optional-sequence
    554                    (repetition-n 5 (concatenation h16 (char #\:))))
     591                   (concatenation
     592                    (variable-repetition 0 5 (concatenation h16 (char #\:)))
     593                    h16))
    555594                  (lit "::")
    556595                  h16)
    557596   (concatenation (optional-sequence
    558                    (repetition-n 6 (concatenation h16 (char #\:))))
     597                   (concatenation
     598                    (variable-repetition 0 6 (concatenation h16 (char #\:)))
     599                    h16))
    559600                  (lit "::"))))
    560601
     
    567608;; IP-literal = "[" ( IPv6address / IPvFuture  ) "]"
    568609(define ip-literal
    569   (concatenation (char #\[) (alternatives ipv6-address ipv-future) (char #\])))
     610  (concatenation (drop-consumed (char #\[))
     611                 (alternatives ipv6-address ipv-future)
     612                 (drop-consumed (char #\]))))
    570613
    571614(define reg-name (repetition (alternatives unreserved pct-encoded sub-delims)))
  • release/5/uri-generic/trunk/alternatives/uri-generic.irregex.scm

    r36564 r36595  
    325325;;
    326326
    327 (define (uri->string uri . rest)
    328   (let-optionals rest ((userinfomap (lambda (u pw) (string-append u ":******" ))))
    329     (with-output-to-string
    330       (lambda ()
    331         (display-fragments
    332          `(,(and-let* ((scheme (uri-scheme uri))) (list scheme ":"))
    333            ,(and-let* ((auth (URI-authority uri))
    334                        (host (URIAuth-host auth)))
    335               (let ((username (URIAuth-username auth))
    336                     (password (URIAuth-password auth))
    337                     (ipv6? (URIAuth-ipv6-host? auth))
    338                     (port (URIAuth-port auth)))
    339                 (list "//" (and username (list (userinfomap
    340                                                 username
    341                                                 password) "@"))
    342                       (if ipv6? "[" "") host (if ipv6? "]" "")
    343                       (and port (list ":" port)))))
    344            ,(path->string (uri-path uri))
    345            ,(and-let* ((query (uri-query uri))) (list "?" query))
    346            ,(and-let* ((fragment (uri-fragment uri))) (list  "#" fragment))))))))
     327(define (uri->string uri . maybe-userinfomap)
     328  (let ((userinfomap (if (pair? maybe-userinfomap)
     329                         (car maybe-userinfomap)
     330                         (lambda (u pw)
     331                           (string-append u ":******" )))))
     332    (cond ((URI? uri)
     333            (with-output-to-string
     334              (lambda ()
     335               (let ((scheme (URI-scheme uri))
     336                     (authority (URI-authority uri))
     337                     (path (URI-path uri))
     338                     (query (URI-query uri))
     339                     (fragment (URI-fragment uri)))
     340                (display-fragments
     341                  (list
     342                   (and scheme (list scheme ":"))
     343                   (and (URIAuth? authority)
     344                        (string? (URIAuth-host authority))
     345                        (let ((username (URIAuth-username authority))
     346                              (password (URIAuth-password authority))
     347                              (host (URIAuth-host authority))
     348                              (ipv6? (URIAuth-ipv6-host? authority))
     349                              (port (URIAuth-port authority)))
     350                          (list "//" (and username (list (userinfomap
     351                                                          username
     352                                                          password) "@"))
     353                                (if ipv6? "[" "") host (if ipv6? "]" "")
     354                                (and port (list ":" port)))))
     355                   (path->string path)
     356                   (and query (list "?" query))
     357                   (and fragment (list  "#" fragment))))))))
     358           (else #f))))
    347359
    348360
Note: See TracChangeset for help on using the changeset viewer.