Changeset 30643 in project


Ignore:
Timestamp:
04/04/14 03:26:05 (7 years ago)
Author:
Ivan Raikov
Message:

uri-generic: applied portability patch from Seth Alves.

Location:
release/4/uri-generic/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/uri-generic/trunk/uri-generic.meta

    r30301 r30643  
    22
    33((egg "uri-generic.egg")
     4
    45 (license "BSD")
     6
    57 (category web)
     8
    69 (needs matchable defstruct)
     10
    711 (test-depends test)
    8  (author "Ivan Raikov and Peter Bex")
     12
     13 (author "Ivan Raikov, Peter Bex, Seth Alves")
     14
    915 (synopsis "URI generic syntax (RFC 3986) parsing and manipulation."))
    1016
  • release/4/uri-generic/trunk/uri-generic.scm

    r30274 r30643  
    44;; Based on the Haskell URI library by  Graham Klyne <gk@ninebynine.org>.
    55;;
    6 ;; Copyright 2008-2014 Ivan Raikov, Peter Bex.
     6;; Copyright 2008-2014 Ivan Raikov, Peter Bex, Seth Alves.
    77;;
    88;;
     
    5656(import chicken scheme)
    5757 
    58 (use extras data-structures ports matchable defstruct
     58(use extras data-structures ports matchable
    5959     srfi-1 srfi-4 srfi-13 srfi-14)
    6060
     61
     62(define uri-error error)
     63
     64(cond-expand
     65 (chicken)
     66 (else
     67  (define (->string obj)
     68    (let ((s (open-output-string)))
     69      (display obj s)
     70      (let ((result (get-output-string s)))
     71        (close-output-port s)
     72        result)))
     73  ))
     74
     75
    6176;; What to do with these?
    62 #;(cond-expand
    63    (utf8-strings (use utf8-srfi-13 utf8-srfi-14))
    64    (else (use srfi-13 srfi-14)))
    65 
    66 (defstruct URI      scheme authority path query fragment)
    67 (defstruct URIAuth  username password host port)
    68 
    69 (define-record-printer (URI x out)
    70   (fprintf out "#(URI scheme=~S authority=~A path=~S query=~S fragment=~S)"
    71            (URI-scheme x)
    72            (URI-authority x)
    73            (URI-path x)
    74            (URI-query x)
    75            (URI-fragment x)))
    76 
    77 (define-record-printer (URIAuth x out)
    78   (fprintf out "#(URIAuth host=~S port=~A)"
    79            (URIAuth-host x)
    80            (URIAuth-port x)))
     77;; #;(cond-expand
     78;;    (utf8-strings (use utf8-srfi-13 utf8-srfi-14))
     79;;    (else (use srfi-13 srfi-14)))
     80
     81(define-record-type <URI>
     82  (make-URI scheme authority path query fragment)
     83  URI?
     84  (scheme URI-scheme URI-scheme-set!)
     85  (authority URI-authority URI-authority-set!)
     86  (path URI-path URI-path-set!)
     87  (query URI-query URI-query-set!)
     88  (fragment URI-fragment URI-fragment-set!))
     89
     90(define-record-type <URIAuth>
     91  (make-URIAuth username password host port)
     92  URIAuth?
     93  (username URIAuth-username URIAuth-username-set!)
     94  (password URIAuth-password URIAuth-password-set!)
     95  (host URIAuth-host URIAuth-host-set!)
     96  (port URIAuth-port URIAuth-port-set!))
     97
     98
     99(cond-expand
     100 (chicken
     101  (define-record-printer (URI x out)
     102    (fprintf out "#(URI scheme=~S authority=~A path=~S query=~S fragment=~S)"
     103             (URI-scheme x)
     104             (URI-authority x)
     105             (URI-path x)
     106             (URI-query x)
     107             (URI-fragment x)))
     108 
     109  (define-record-printer (URIAuth x out)
     110    (fprintf out "#(URIAuth host=~S port=~A)"
     111             (URIAuth-host x)
     112             (URIAuth-port x))))
     113 (else))
     114
     115
     116(define (update-URI uri . args)
     117  (let loop ((args args)
     118             (new-scheme (URI-scheme uri))
     119             (new-authority (URI-authority uri))
     120             (new-path (URI-path uri))
     121             (new-query (URI-query uri))
     122             (new-fragment (URI-fragment uri)))
     123    (cond ((null? args)
     124           (make-URI new-scheme new-authority new-path new-query new-fragment))
     125          ((null? (cdr args))
     126           (uri-error "malformed arguments to update-URI"))
     127          (else
     128           (let ((key (car args))
     129                 (value (cadr args)))
     130             (loop (cddr args)
     131                   (if (eq? key 'scheme) value new-scheme)
     132                   (if (eq? key 'authority) value new-authority)
     133                   (if (eq? key 'path) value new-path)
     134                   (if (eq? key 'query) value new-query)
     135                   (if (eq? key 'fragment) value new-fragment)))))))
     136
     137
     138(define (update-URIAuth uri-auth . args)
     139  (let loop ((args args)
     140             (new-username (URIAuth-username uri-auth))
     141             (new-password (URIAuth-password uri-auth))
     142             (new-host (URIAuth-host uri-auth))
     143             (new-port (URIAuth-port uri-auth)))
     144    (cond ((null? args)
     145           (make-URIAuth new-username new-password new-host new-port))
     146          ((null? (cdr args))
     147           (uri-error "malformed arguments to update-URIAuth"))
     148          (else
     149           (let ((key (car args))
     150                 (value (cadr args)))
     151             (loop (cddr args)
     152                   (if (eq? key 'username) value new-username)
     153                   (if (eq? key 'password) value new-password)
     154                   (if (eq? key 'host) value new-host)
     155                   (if (eq? key 'port) value new-port)))))))
     156
    81157
    82158(define uri-reference? URI?)
     
    113189(define update-authority update-URIAuth)
    114190
    115 (define update-uri
     191
     192(define update-uri*
    116193  (let ((unset (list 'unset)))
    117    (lambda (uri . key/values)
    118      (apply
    119       (lambda (#!key
    120                (scheme (URI-scheme uri)) (path (URI-path uri))
    121                (query (URI-query uri)) (fragment (URI-fragment uri))
    122                (auth unset) (authority unset))
     194    (lambda (uri . args)
     195      (let loop ((key/values args)
     196                 (scheme (URI-scheme uri))
     197                 (path (URI-path uri))
     198                 (query (URI-query uri))
     199                 (fragment (URI-fragment uri))
     200                 (auth unset)
     201                 (authority unset))
     202        (cond
     203         ((null? key/values)
    123204        (let* ((base-auth (or
    124205                           (cond
     
    126207                            ((not (eq? unset authority)) authority)
    127208                            (else (URI-authority uri)))
    128                            (make-URIAuth)))
    129                (updated-auth (apply update-authority base-auth key/values))
    130                (final-auth (if (equal? (make-URIAuth) updated-auth)
     209                             (make-URIAuth #f #f #f #f)))
     210                 (updated-auth (apply update-authority base-auth args))
     211                 (final-auth (if (uri-auth-equal? (make-URIAuth #f #f #f #f)
     212                                                  updated-auth)
    131213                               #f
    132214                               updated-auth)))
    133           (make-URI scheme: scheme path: path query: query fragment: fragment
    134                     authority: final-auth))) key/values))))
    135 
    136 (define (make-uri . key/values)
    137   (apply update-uri (make-URI path: '()) key/values))
     215            (make-URI scheme final-auth path query fragment)))
     216         ((null? (cdr key/values))
     217          (uri-error "malformed arguments to update-uri"))
     218         ((not (memq (car key/values)
     219                     '(scheme authority path query fragment
     220                              username password host port)))
     221          (uri-error "unknown argument to update-uri" (car key/values)))
     222         (else
     223          (let ((key (car key/values))
     224                (value (cadr key/values)))
     225            (loop (cddr key/values)
     226                  (if (eq? key 'scheme) value scheme)
     227                  (if (eq? key 'path) value path)
     228                  (if (eq? key 'query) value query)
     229                  (if (eq? key 'fragment) value fragment)
     230                  (if (eq? key 'auth) value auth)
     231                  (if (eq? key 'authority) value authority)))))))))
     232
     233
     234(cond-expand
     235
     236 (chicken
     237  (define update-uri
     238    (let ((unset (list 'unset)))
     239      (lambda (uri . key/values)
     240        (apply
     241         (lambda (#!key
     242                  (scheme (URI-scheme uri)) (path (URI-path uri))
     243                  (query (URI-query uri)) (fragment (URI-fragment uri))
     244                  (auth unset) (authority unset)
     245                  (username unset) (password unset)
     246                  (host unset) (port unset))
     247           (let* ((args (list 'scheme scheme
     248                              'path path
     249                              'query query
     250                              'fragment fragment))
     251                  (args (if (not (eq? auth unset))
     252                            (append args (list 'auth auth)) args))
     253                  (args (if (not (eq? authority unset))
     254                            (append args (list 'authority authority)) args))
     255                  (args (if (not (eq? username unset))
     256                            (append args (list 'username username)) args))
     257                  (args (if (not (eq? password unset))
     258                            (append args (list 'password password)) args))
     259                  (args (if (not (eq? host unset))
     260                            (append args (list 'host host)) args))
     261                  (args (if (not (eq? port unset))
     262                            (append args (list 'port port)) args))
     263                  )
     264             (apply update-uri* uri args)))
     265         key/values)))))
     266
     267 (else
     268  (define update-uri update-uri*)))
     269
     270
     271(define (make-uri* . key/values)
     272  (apply update-uri* (make-URI #f #f '() #f #f) key/values))
     273
     274(cond-expand
     275
     276 (chicken
     277  (define (make-uri . key/values)
     278    (apply update-uri (make-URI #f #f '() #f #f) key/values)))
     279 
     280 (else
     281  (define make-uri make-uri*)))
     282
     283
     284(define (uri-equal? a b)
     285  (or (and (not a) (not b))
     286      (and (equal? (URI-scheme a) (URI-scheme b))
     287           (uri-auth-equal? (URI-authority a) (URI-authority b))
     288           (equal? (URI-path a) (URI-path b))
     289           (equal? (URI-query a) (URI-query b))
     290           (equal? (URI-fragment a) (URI-fragment b)))))
     291
     292
     293(define (uri-auth-equal? a b)
     294  (or (and (not a) (not b))
     295      (and
     296       (equal? (URIAuth-username a) (URIAuth-username b))
     297       (equal? (URIAuth-password a) (URIAuth-password b))
     298       (equal? (URIAuth-host a) (URIAuth-host b))
     299       (equal? (URIAuth-port a) (URIAuth-port b)))))
     300
    138301
    139302;; Character classes
     
    300463                                                      (else (list #f rst)))))
    301464                               (and (null? rst)
    302                                     (make-URI scheme: (string->symbol (list->string us)) authority: ua
    303                                               path: (uri-path-list->path up) query: (and uq (uri-char-list->string uq))
    304                                               fragment: (and uf (uri-char-list->string uf))))))
     465                        (make-URI (string->symbol (list->string us))
     466                                  ua
     467                                  (uri-path-list->path up)
     468                                  (and uq (uri-char-list->string uq))
     469                                  (and uf (uri-char-list->string uf))))))
    305470                  (else #f)))))
    306471
     
    349514               ((uh rst)      (host rst))
    350515               ((up rst)      (or (port rst) (list #f rst))))
    351               (list (make-URIAuth username: (and uu (uri-char-list->string uu))
    352                                   password: (and uw (uri-char-list->string uw))
    353                                   host: (uri-char-list->string uh)
    354                                   port: (and (pair? up) (string->number (list->string up))))
     516              (list
     517               (make-URIAuth
     518                (and uu (uri-char-list->string uu))
     519                (and uw (uri-char-list->string uw))
     520                (uri-char-list->string uh)
     521                (and (pair? up) (string->number (list->string up))))
    355522                    rst)))
    356523
     
    397564            (match (or (ipv6-address rst) (ipv-future rst))
    398565                   ((ua (#\] . rst))  (list ua rst))
    399                    (else (error 'ip-literal "malformed ip literal" (try-ip-literal->string rst)))))
     566                   (else (uri-error 'ip-literal "malformed ip literal"
     567                                (try-ip-literal->string rst)))))
    400568         (else #f)))
    401569
     
    515683                              (else #f)))
    516684              (else #f))
    517       (error 'ipv6-address "malformed ipv6 address" (try-ip-literal->string s))))
     685      (uri-error 'ipv6-address "malformed ipv6 address" (try-ip-literal->string s))))
    518686
    519687
     
    700868                                         (else (list #f rst)))))
    701869                   (and (null? rst)
    702                         (make-URI scheme: #f authority: ua path: (uri-path-list->path up)
    703                                   query: (and uq (uri-char-list->string uq))
    704                                   fragment: (and uf (uri-char-list->string uf)))))))
     870                        (make-URI #f ua
     871                                  (uri-path-list->path up)
     872                                  (and uq (uri-char-list->string uq))
     873                                  (and uf (uri-char-list->string uf)))))))
    705874
    706875(define (relative-ref? u)
     
    728897                                                     (else (list #f rst)))))
    729898                               (match rst
    730                                       ((#\# . rst) (error 'absolute-uri "fragments are not permitted in absolute URI"))
    731                                       (else (make-URI scheme: (string->symbol (list->string us)) authority: ua
    732                                                       path: (uri-path-list->path up)
    733                                                       query: (and uq (uri-char-list->string uq))
    734                                                       fragment: #f)))))
    735                   (else (error 'absolute-uri "no scheme found in URI string"))))))
     899                      ((#\# . rst) (uri-error 'absolute-uri "fragments are not permitted in absolute URI"))
     900                      (else (make-URI (string->symbol (list->string us))
     901                                      ua
     902                                      (uri-path-list->path up)
     903                                      (and uq (uri-char-list->string uq))
     904                                      #f)))))
     905          (else (uri-error 'absolute-uri "no scheme found in URI string"))))))
    736906
    737907(define (absolute-uri? u)
     
    745915
    746916
    747 (define (uri->string uri . rest)
    748    (let-optionals rest ((userinfomap (lambda (u pw) (string-append u ":******" ))))
    749     (match uri
    750            (($ URI scheme authority path query fragment)
     917(define (uri->string uri . maybe-userinfomap)
     918  (let ((userinfomap (if (pair? maybe-userinfomap)
     919                         (car maybe-userinfomap)
     920                         (lambda (u pw)
     921                           (string-append u ":******" )))))
     922    (cond ((URI? uri)
    751923            (with-output-to-string
    752924              (lambda ()
     925               (let ((scheme (URI-scheme uri))
     926                     (authority (URI-authority uri))
     927                     (path (URI-path uri))
     928                     (query (URI-query uri))
     929                     (fragment (URI-fragment uri)))
    753930                (display-fragments
    754                  `(,(and scheme (list scheme ":"))
    755                    ,(match authority
    756                            (($ URIAuth username password (and host (? string?)) port)
    757                             (list "//" (and username (list (userinfomap username password) "@"))
    758                                   host (and port (list ":" port))))
    759                            (else #f))
    760                    ,(path->string path)
    761                    ,(and query (list "?" query))
    762                    ,(and fragment (list  "#" fragment)))))))
     931                  (list
     932                   (and scheme (list scheme ":"))
     933                   (and (URIAuth? authority)
     934                        (string? (URIAuth-host authority))
     935                        (let ((username (URIAuth-username authority))
     936                              (password (URIAuth-password authority))
     937                              (host (URIAuth-host authority))
     938                              (port (URIAuth-port authority)))
     939                          (list "//" (and username (list (userinfomap
     940                                                          username
     941                                                          password) "@"))
     942                                host (and port (list ":" port)))))
     943                   (path->string path)
     944                   (and query (list "?" query))
     945                   (and fragment (list  "#" fragment))))))))
    763946           (else #f))))
     947
     948
    764949
    765950(define (display-fragments b)
     
    796981; specific: ((uri-authority uri) (uri-path uri) (uri-query uri)).
    797982
    798 (define (uri->list uri . rest)
    799   (let-optionals rest ((userinfomap (lambda (u pw) (string-append u ":******" ))))
    800     (match uri
    801            (($ URI scheme authority path query fragment)
    802             `(,scheme (,(uri-auth->list authority userinfomap) ,path ,query) ,fragment))
     983(define (uri->list uri . maybe-userinfomap)
     984  (let ((userinfomap (if (pair? maybe-userinfomap)
     985                         (car maybe-userinfomap)
     986                         (lambda (u pw)
     987                           (string-append u ":******" )))))
     988    (cond ((URI? uri)
     989           `(,(URI-scheme uri)
     990             (,(uri-auth->list (URI-authority uri) userinfomap)
     991              ,(URI-path uri) ,(URI-query uri))
     992             ,(URI-fragment uri)))
    803993           (else #f))))
    804994
    805995(define (uri-auth->list uri-auth userinfomap)
    806   (match uri-auth
    807          (($ URIAuth username password regname port)
    808           `(,(if (and username password) (userinfomap username password) #f) ,regname ,port ))
     996  (cond ((URIAuth? uri-auth)
     997         `(,(and (URIAuth-username uri-auth) (URIAuth-password uri-auth)
     998                 (userinfomap (URIAuth-username uri-auth)
     999                              (URIAuth-password uri-auth)))
     1000           ,(URIAuth-host uri-auth)
     1001           ,(URIAuth-port uri-auth)))
    8091002         (else #f)))
    8101003                         
     
    8121005;;  Percent encoding and decoding
    8131006
    814 (define (uri-encode-string str #!optional (char-set (char-set-complement
    815                                                      char-set:uri-unreserved)))
    816   (let ((clst (string->list str)))
     1007(define (uri-encode-string str . maybe-char-set)
     1008  (let ((char-set (if (pair? maybe-char-set)
     1009                      (car maybe-char-set)
     1010                      (char-set-complement char-set:uri-unreserved)))
     1011        (clst (string->list str)))
    8171012    (uri-char-list->string
    8181013     (pct-encode clst char-set))))
    8191014
    820 (define (uri-decode-string str #!optional (char-set char-set:full))
    821   (let ((str1 (uri-string->char-list str)))
     1015(define (uri-decode-string str . maybe-char-set)
     1016  (let ((char-set (if (pair? maybe-char-set)
     1017                      (car maybe-char-set)
     1018                      char-set:full))
     1019        (str1 (uri-string->char-list str)))
    8221020    (and str1 (uri-char-list->string (pct-decode str1 char-set)))))
    8231021   
     
    8601058(define (uri-relative-to ref base)
    8611059  (and (uri-reference? ref) (uri-reference? base)
    862        (cond ((uri-scheme ref)      (update-URI ref
    863                                                 path: (just-segments ref)))
    864              ((uri-authority ref)   (update-URI ref
    865                                                 path: (just-segments ref)
    866                                                 scheme: (uri-scheme base)))
     1060       (cond ((uri-scheme ref)
     1061              (update-URI ref 'path (just-segments ref)))
     1062             ((uri-authority ref)
     1063              (update-URI ref
     1064                          'path (just-segments ref)
     1065                          'scheme (uri-scheme base)))
    8671066             ((let ((p (uri-path ref))) (and (not (null? p)) p)) =>
    8681067              (lambda (ref-path)
    8691068                (if (and (pair? ref-path) (eq? '/ (car ref-path)))
    8701069                    (update-URI ref
    871                                 scheme: (uri-scheme base)
    872                                 authority: (uri-auth base)
    873                                 path: (just-segments ref))
     1070                                'scheme (uri-scheme base)
     1071                                'authority (uri-auth base)
     1072                                'path (just-segments ref))
    8741073                    (update-URI ref
    875                                 scheme: (uri-scheme base)
    876                                 authority: (uri-auth base)
    877                                 path: (merge-paths base ref-path)))))
    878              ((uri-query ref) (update-URI ref
    879                                           scheme: (uri-scheme base)
    880                                           authority: (uri-auth base)
    881                                           path: (merge-paths base (list ""))))
     1074                                'scheme (uri-scheme base)
     1075                                'authority (uri-auth base)
     1076                                'path (merge-paths base ref-path)))))
     1077             ((uri-query ref)
     1078              (update-URI ref
     1079                          'scheme (uri-scheme base)
     1080                          'authority (uri-auth base)
     1081                          'path (merge-paths base (list ""))))
    8821082             (else (update-URI ref
    883                                path: (URI-path base)
    884                                scheme: (URI-scheme base)
    885                                authority: (URI-authority base)
    886                                query: (URI-query base))))))
     1083                               'path (URI-path base)
     1084                               'scheme (URI-scheme base)
     1085                               'authority (URI-authority base)
     1086                               'query (URI-query base))))))
    8871087
    8881088(define (just-segments u)
     
    9401140(define (uri-relative-from uabs base)
    9411141  (cond ((ucdiff? uri-scheme uabs base)      (update-URI uabs))
    942         ((ucdiff? uri-authority uabs base)   (update-URI uabs scheme: #f))
     1142        ((ucdiff? uri-authority uabs base) (update-URI uabs 'scheme #f))
    9431143        ;; Special case: no relative representation for http://a/ -> http://a
    9441144        ;; ....unless that should be a path of ("..")
    945         ((null? (uri-path uabs))             (update-URI uabs scheme: #f))
     1145        ((null? (uri-path uabs))
     1146         (update-URI uabs 'scheme #f))
    9461147        ((ucdiff? uri-path uabs base)
    9471148         (update-URI uabs
    948                      scheme: #f
    949                      authority: #f
    950                      path: (rel-path-from
     1149                     'scheme #f
     1150                     'authority #f
     1151                     'path (rel-path-from
    9511152                            (remove-dot-segments (uri-path uabs))
    9521153                            (remove-dot-segments (uri-path base)))))
    9531154        ((ucdiff? uri-query uabs base)
    9541155         (update-URI uabs
    955                      scheme: #f
    956                      authority: #f
    957                      path: (list)))
     1156                     'scheme #f
     1157                     'authority #f
     1158                     'path (list)))
    9581159        (else
    9591160         (update-URI uabs
    960                      scheme: #f
    961                      authority: #f
    962                      query: #f
    963                      path: (list)))))
     1161                     'scheme #f
     1162                     'authority #f
     1163                     'query #f
     1164                     'path (list)))))
    9641165
    9651166(define (ucdiff? sel u1 u2)
     
    9831184               (rel-path-from1 sa1 sb1)
    9841185               pabs)))
    985          (else (error 'rel-path-from "Both URI paths must be absolute" pabs base))))
     1186         (else (uri-error 'rel-path-from "Both URI paths must be absolute" pabs base))))
    9861187
    9871188(define (make-rel-path x)
     
    10361237         (scheme         (string->symbol (string-downcase (->string (uri-scheme uri)))))
    10371238         (host           (normalize-pct-encoding (string-downcase (uri-host uri)))))
    1038     (update-uri normalized-uri scheme: scheme host: host)))
     1239    (update-uri* normalized-uri 'scheme scheme 'host host)))
    10391240
    10401241(define (normalize-pct-encoding str)
     
    10491250
    10501251(define (uri-normalize-path-segments uri)
    1051   (update-URI uri path: (just-segments uri)))
     1252  (update-URI uri 'path (just-segments uri)))
    10521253
    10531254(define (uri-path-absolute? uri)
  • release/4/uri-generic/trunk/uri-generic.setup

    r30274 r30643  
    11;; -*- Hen -*-
    22
    3 (compile -s -O2 uri-generic.scm -j uri-generic)
    4 (compile -s -O2 uri-generic.import.scm)
     3(compile -s -S -O2 uri-generic.scm -j uri-generic)
     4(compile -s -S -O2 uri-generic.import.scm)
    55
    66(install-extension
     
    1313
    1414  ;; Assoc list with properties for your extension:
    15   '((version 2.39)))
     15  '((version 2.41)))
Note: See TracChangeset for help on using the changeset viewer.