Changeset 12986 in project


Ignore:
Timestamp:
01/11/09 23:37:40 (11 years ago)
Author:
sjamaan
Message:

Clean up a few bits, make the query separator available everywhere by putting it in the struct (which is ugly, so I will need to come up with something better soon)

Location:
release/4/uri-common/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/uri-common/trunk/tests/run.scm

    r12984 r12986  
    6060                                           (first u)
    6161                                           (third u)))
    62                                   (uri (uri-common (first u))))
     62                                  (uri (uri-common-reference (first u))))
    6363                              (test (sprintf "~S decoded as ~S" in internal)
    6464                                    internal ((cadr p) uri))
     
    8989                                  (input (first u))
    9090                                  (oexp (second u))
    91                                   (oact (update-uri-common (uri-common "")
    92                                                            slotname input)))
     91                                  (oact (update-uri-common
     92                                         (uri-common-reference "")
     93                                         slotname input)))
    9394                             (test (sprintf "~S -> ~S" input oexp)
    9495                                   oexp (uri-common->string oact))))
     
    150151     )
    151152    (((img . #t) (avail . #t) (name . #t) (price . #t))
    152      "img;avail;name;price")))
     153     "img;avail;name;price")
     154    (((foo+bar . "mooh+qux") (|foo bar| . "mooh qux"))
     155     "foo%2Bbar=mooh%2Bqux;foo+bar=mooh+qux")
     156    (((no+value . #t) (|no value| . #t))
     157     "no%2Bvalue;no+value")))
    153158
    154159(test-group "form-urlencoding-hoehrmann-draft-cases"
  • release/4/uri-common/trunk/uri-common.scm

    r12984 r12986  
    55;; encoding/decoding
    66;;
    7 ; Copyright (c) 2008, Peter Bex
     7; Copyright (c) 2008-2009, Peter Bex
    88; All rights reserved.
    99;
     
    4141
    4242(module uri-common
    43   (uri-common update-uri-common
     43  (uri-common-reference absolute-uri-common
     44   uri-common->uri-generic uri-common->uri-generic
     45   update-uri-common uri-common?
    4446   uri-common-scheme uri-common-username uri-common-password
    45    uri-common-host uri-common-port uri-common-path
    46    uri-common-query uri-common-fragment uri-common-generic
     47   uri-common-host uri-common-port uri-common-path uri-common-query
     48   uri-common-fragment
    4749   uri-common->string form-urlencode form-urldecode
     50   uri-common-relative-to uri-common-relative-from
     51   uri-common-normalize-path-segments uri-common-normalize-case
    4852   char-set:query/fragment)
    4953
     
    6670
    6771;; A common URI is a generic URI plus stored decoded versions of most components
     72;; It also contains a query separator because we need that every time
     73;; we encode/decode between a uri-generic and uri-common object.
     74;;
     75;; TODO: This results in horrible code, reproducing the query bit
     76;;  every time.  Find a way to clean this up, without requiring the
     77;;  user to wrap every call to any uri-common procedure that delegates
     78;;  to uri-generic in a PARAMETERIZE call...  (besides this being very
     79;;  ugly, the user shouldn't need to know when we use uri-generic
     80;;  internally and when not)
    6881(defstruct URI-common
    69   generic username password host path query fragment)
     82  generic username password host path query fragment
     83  query-separator)
    7084
    7185(define-record-printer (URI-common x out)
    72   (fprintf out "#(URI-common scheme=~S host=~S path=~S query=~S fragment=~S)"
     86  (fprintf out "#(URI-common scheme=~S host=~S path=~S query=~S fragment=~S query-separator=~S)"
    7387           (uri-scheme (URI-common-generic x))
    7488           (URI-common-host x)
    7589           (URI-common-path x)
    7690           (URI-common-query x)
    77            (URI-common-fragment x)))
    78 
    79 (define (uri-common u)
    80   (let ((uri (normalize-uri (if (string? u) (uri-reference u) u))))
    81     (make-URI-common generic: uri
    82                      username: (decode-string* (uri-username uri))
    83                      password: (decode-string* (uri-password uri))
    84                      host: (decode-string* (uri-host uri))
    85                      path: (decode-path (uri-path uri))
    86                      query: (form-urldecode (uri-query uri))
    87                      fragment: (decode-string* (uri-fragment uri))
    88                      )))
     91           (URI-common-fragment x)
     92           (URI-common-query-separator x)))
     93
     94(define (decode-string* s)
     95  (and s (uri-decode-string s)))
     96
     97(define (uri-common-reference u #!key (query-separator (form-urlencoded-separator)))
     98  (uri-generic->uri-common (uri-reference u) query-separator: query-separator))
     99(define (absolute-uri-common u #!key (query-separator (form-urlencoded-separator)))
     100  (uri-generic->uri-common (absolute-uri u) query-separator: query-separator))
     101
     102(define (uri-generic->uri-common uri #!key (query-separator (form-urlencoded-separator)))
     103  (make-URI-common generic: uri
     104                   username: (decode-string* (uri-username uri))
     105                   password: (decode-string* (uri-password uri))
     106                   host:     (decode-string* (uri-host uri))
     107                   path:     (decode-path (uri-path uri))
     108                   query:    (form-urldecode (uri-query uri)
     109                                             separator: query-separator)
     110                   fragment: (decode-string* (uri-fragment uri))
     111                   query-separator: query-separator))
     112
     113(define (uri-common->uri-generic uri)
     114  (URI-common-generic uri))
    89115
    90116;; Accessors
    91 (define uri-common-scheme (compose uri-scheme URI-common-generic))
     117(define uri-common?         URI-common?)
     118(define uri-common-scheme   (compose uri-scheme URI-common-generic))
    92119(define uri-common-username URI-common-username)
    93120(define uri-common-password URI-common-password)
    94 (define uri-common-host URI-common-host)
    95 (define uri-common-path URI-common-path)
    96 (define uri-common-query URI-common-query)
     121(define uri-common-host     URI-common-host)
     122(define uri-common-path     URI-common-path)
     123(define uri-common-query    URI-common-query)
    97124(define uri-common-fragment URI-common-fragment)
    98 (define uri-common-generic URI-common-generic)
    99125
    100126(define (uri-common-port uc)
     
    115141    u))
    116142
     143(define (encode-string* s . rest)
     144  (and s (apply uri-encode-string s rest)))
     145
    117146(define update-uri-common
    118147  (let ((unset (list 'unset)))
    119148    (lambda (uc #!key
    120149                (scheme unset) (username unset) (password unset) (host unset)
    121                 (path unset) (query unset) (fragment unset))
     150                (path unset) (query unset) (fragment unset)
     151                (query-separator unset))
    122152      (let ((uc (update-URI-common uc))) ;; new copy
    123153        (unless (eq? scheme unset)
     
    144174                          path: (encode-path path)))
    145175          (URI-common-path-set! uc path))
     176        ;; First the separator, so we can decode the query, if needed
     177        (unless (eq? query-separator unset)
     178          (URI-common-query-separator-set! uc query-separator))
    146179        (unless (eq? query unset)
    147180          (URI-common-generic-set!
    148181           uc (update-uri (URI-common-generic uc)
    149                           query: (form-urlencode query)))
     182                          query: (form-urlencode
     183                                  query
     184                                  separator: (URI-common-query-separator uc))))
    150185          (URI-common-query-set! uc query))
    151186        (unless (eq? fragment unset)
     
    156191          (URI-common-fragment-set! uc fragment))
    157192        uc))))
    158 
    159 
    160 (define (encode-string* s . rest)
    161   (and s (apply uri-encode-string s rest)))
    162193
    163194(define (encode-path p)
     
    195226;; http://ietfreport.isoc.org/idref/draft-hoehrmann-urlencoded
    196227
    197 ;; This should be changed globally to semicolon when using XForms,
    198 ;; since that's the default.
    199228(define form-urlencoded-separator (make-parameter ";&"))
    200229
     
    205234                            (if (string? separator-chars)
    206235                                separator-chars
    207                                 (char-set->string separator-chars)) 1)))
     236                                (char-set->string separator-chars)) 1))
     237              (enc (lambda (s)
     238                     (string-translate*
     239                      (uri-encode-string
     240                       s
     241                       (char-set-union separator-chars
     242                                       (char-set #\= #\+)
     243                                       (char-set-delete char-set:query/fragment
     244                                                        #\space)))
     245                      '((" " . "+"))))))
    208246         (string-join
    209247          (reverse (fold
    210248                    (lambda (arg query)
    211                       (let ((enc (lambda (s)
    212                                    (string-translate*
    213                                     (uri-encode-string
    214                                      s
    215                                      (char-set-delete
    216                                       (char-set-union separator-chars
    217                                                       (char-set #\= #\+)
    218                                                       char-set:query/fragment)
    219                                       #\space))
    220                                     '((" " . "+"))))))
    221                         (match arg
    222                                ((a . #f) query)
    223                                ((a . #t) (cons (enc (->string a)) query))
    224                                ((a . b) (cons
    225                                          (sprintf "~A=~A"
    226                                                   (enc (->string a))
    227                                                   (enc b))
    228                                          query)))))
     249                      (match arg
     250                             ((a . #f) query)
     251                             ((a . #t) (cons (enc (->string a)) query))
     252                             ((a . b) (cons
     253                                       (sprintf "~A=~A"
     254                                                (enc (->string a))
     255                                                (enc b))
     256                                       query))))
    229257                    '() alist))
    230258          join-string))))
     
    233261  (if query
    234262      (map (lambda (part)
    235              (let ((idx (string-index part #\=)))
     263             (let ((idx (string-index part #\=))
     264                   (decode (lambda (s)
     265                             (uri-decode-string
     266                              (string-translate* s '(("+" . "%20")))))))
    236267               (if idx
    237                    (cons (string->symbol
    238                           (uri-decode-string (string-translate*
    239                                               (string-take part idx)
    240                                               '(("+" . "%20")))))
    241                          (uri-decode-string (string-translate*
    242                                              (string-drop part (add1 idx))
    243                                              '(("+" . "%20")))))
    244                    (cons (string->symbol (uri-decode-string part))
     268                   (cons (string->symbol (decode (string-take part idx)))
     269                         (decode (string-drop part (add1 idx))))
     270                   (cons (string->symbol (decode part))
    245271                         #t))))
    246272           (string-split query (char-set->string (->char-set separator)) #t))
    247273      '())) ; _always_ provide a list interface for the query, even if not there
    248 
    249 (define (decode-string* s)
    250   (and s (uri-decode-string s)))
    251274
    252275(define (decode-path p)
     
    258281;; Simple convenience procedures
    259282(define (uri-common->string uri . args)
    260   (apply uri->string (uri-common-generic uri) args))
     283  (apply uri->string (URI-common-generic uri) args))
     284
     285(define (wrap proc)
     286  (lambda args
     287    (uri-generic->uri-common (apply proc (map URI-common-generic args)))))
     288
     289(define uri-common-relative-to             (wrap uri-relative-to))
     290(define uri-common-relative-from           (wrap uri-relative-from))
     291(define uri-common-normalize-case          (wrap uri-normalize-case))
     292(define uri-common-normalize-path-segments (wrap uri-normalize-path-segments))
    261293
    262294)
Note: See TracChangeset for help on using the changeset viewer.