rl3/web/uri.sls

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; Bravais' Edito Princeps: EBook Tool Suite
   3 ;; Copyright (C) 2007  Raymond Paul Racine
   4 ;;
   5 ;; This program is free software: you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation, either version 3 of the License, or
   8 ;; (at your option) any later version.
   9 ;;
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18
  19 (library
  20  (rl3 web uri char-sets)
  21
  22  (export
  23   encode-char
  24   digit-char? hex-char? pchar? pct-encoded-char?
  25   scheme-start-ch? scheme-tail-ch? sub-delim-char? unreserved-char?
  26   unsafe-char?)
  27
  28  (import
  29   (rnrs base)
  30   (only (rnrs unicode)
  31         char-ci>=? char-ci<=? char-downcase))
  32
  33  (define encode-char
  34    (lambda (ch)
  35      (string-append "%" (number->string (char->integer ch) 16))))
  36
  37  (define encode-char?
  38    (lambda (ch)
  39      (or (unsafe-char? ch))))
  40
  41  (define digit-char?
  42    (lambda (ch)
  43      (and
  44       (char>=? ch #\0)
  45       (char<=? ch #\9))))
  46
  47  (define alphabet-char?
  48    (lambda (ch)
  49      (and
  50       (char-ci>=? ch #\a)
  51       (char-ci<=? ch #\z))))
  52
  53  (define hex-char?
  54    (lambda (ch)
  55      (or
  56       (digit-char? ch)
  57       (case (char-downcase ch)
  58         ((#\a #\b #\c #\d #\e #\f) #t)
  59         (else #f)))))
  60
  61  (define unreserved-char?
  62    (lambda (ch)
  63      (or
  64       (alphabet-char? ch)
  65       (digit-char? ch)
  66       (case ch
  67         ((#\. #\_ #\~ #\\ #\-) #t)
  68         (else #f)))))
  69
  70  (define reserved
  71    (lambda (ch)
  72      (or
  73       (general-delim-char? ch)
  74       (sub-delim-char? ch))))
  75
  76  ;; rtf1138
  77  (define unsafe-char?
  78    (lambda (ch)
  79      (case ch
  80        ((#\{ #\} #\| #\\ #\^ #\~ #\[ #\] #\`)
  81         #t)
  82        (else #f))))
  83
  84  (define general-delim-char?
  85    (lambda (ch)
  86      (case ch
  87        ((#\: #\/ #\? #\# #\[ #\] #\@) #t)
  88        (else #f))))
  89
  90  (define sub-delim-char?
  91    (lambda (ch)
  92      (case ch
  93        ((#\! #\$ #\& #\' #\( #\) #\* #\+ #\, #\; #\=) #t)
  94        (else #f))))
  95
  96  (define pct-encoded-char?
  97    (lambda (ch)
  98      (or
  99       (eq? ch #\%)
 100       (hex-char? ch))))
 101
 102  (define pchar?
 103    (lambda (ch)
 104      (or
 105       (unreserved-char? ch)
 106       (pct-encoded-char? ch)
 107       (sub-delim-char? ch)
 108       (case ch
 109         ((#\: #\@) #t)
 110         (else #f)))))
 111
 112  (define scheme-start-ch? alphabet-char?)
 113
 114  (define scheme-tail-ch?
 115    (lambda (ch)
 116      (or
 117       (scheme-start-ch? ch)
 118       (digit-char? ch)
 119       (case ch
 120         ((#\+ #\- #\.) #t)
 121         (else #f)))))
 122
 123  )
 124
 125 (library
 126
 127  (rl3 web uri)
 128
 129  (export
 130   url-decode-string
 131   parse-uri parse-authority uri->string
 132   ;; Authority rtd
 133   make-authority authority? authority->string authority-equal?
 134   authority-username authority-host authority-port
 135   ;; URI rtd
 136   make-uri uri?
 137   uri-scheme uri-authority uri-path uri-query uri-fragment)
 138
 139  (import
 140   (rnrs base)
 141   (only (rnrs control)
 142         unless)
 143   (only (rnrs io simple)
 144         display newline
 145         eof-object? peek-char read-char write-char)
 146   (only (rnrs io ports)
 147         get-char put-char
 148         open-string-input-port)
 149   (primitives open-output-string get-output-string)
 150   (err5rs records syntactic)
 151   (only (larceny records printer)
 152         rtd-printer-set!)
 153   (rl3 env prelude)
 154   (only (rl3 web uri char-sets)
 155         hex-char? digit-char?
 156         pchar?
 157         scheme-start-ch?
 158         scheme-tail-ch?
 159         pct-encoded-char?
 160         sub-delim-char?
 161         unreserved-char?))
 162
 163  (define url-decode-string
 164    (lambda (str)
 165      (let ((op (open-output-string))
 166            (ip (open-string-input-port str)))
 167        (let loop ((ch (get-char ip)))
 168          (if (eof-object? ch)
 169              (get-output-string op)
 170              (if (char=? #\% ch)
 171                  (let ((ch1 (get-char ip)))
 172                    (if (and (not (eof-object? ch1))
 173                             (hex-char? ch1))
 174                        (let ((ch2 (get-char ip)))
 175                          (if (and (not (eof-object? ch2))
 176                                   (hex-char? ch2))
 177                              (begin
 178                                (put-char op (integer->char (string->number (list->string (list ch1 ch2)) 16))) ;; use (let ((buff (make-string 2))) ???
 179                                (loop (get-char ip)))
 180                              (begin              ;; got %d? so write '%' and digit and carryon
 181                                (put-char op #\%)
 182                                (put-char op ch1)
 183                                (unless (eof-object? ch2)
 184                                  (put-char op ch2))
 185                                (loop (get-char ip)))))
 186                        (begin                   ;; got %? so write them and carryon
 187                          (put-char op #\%)
 188                          (unless (eof-object? ch1)
 189                            (put-char op ch1))
 190                          (loop (get-char ip)))))
 191                  (begin
 192                    (unless (eof-object? ch)
 193                      (put-char op ch))
 194                    (loop (get-char ip)))))))))
 195
 196  ;; all strings or #f
 197  (define-record-type authority #t #t username host port)
 198
 199  ;;all strings or #f, each string is a major piece of the uri.
 200  (define-record-type uri ctor-uri #t scheme authority path query fragment)
 201
 202  (define null-string?
 203    (lambda (s)
 204      (if (string? s)
 205          (zero? (string-length s))
 206          #f)))
 207
 208  (define make-uri
 209    (lambda (scheme user host port path query fragment)
 210      (assert (and
 211               (string? scheme)
 212               (or (string? user)
 213                   (and (boolean? user)
 214                        (not user)))
 215               (string? host)
 216               (or (number? port)
 217                   (and (boolean? port)
 218                        (not port)))
 219               (string? path)
 220               (string? query)
 221               (string? fragment)))
 222      (let ((sport (if (number? port)
 223                       (number->string port)
 224                       port)))
 225        (let ((authority (authority->string (make-authority (if (null-string? user)
 226                                                                #f user)
 227                                                            host (if (null-string? sport) #f sport)))))
 228          (if (null-string? scheme)
 229              #f
 230              (ctor-uri scheme authority
 231                        (if (null-string? path)
 232                            "/"
 233                            path)
 234                        (if (null-string? query)
 235                            #f
 236                            query)
 237                        (if (null-string? fragment)
 238                            #f
 239                            fragment)))))))
 240
 241  (define maybe
 242    (lambda (field prefix)
 243      (if field (string-append prefix field) "")))
 244
 245  (define uri->string
 246    (lambda (uri)
 247      (string-append
 248       (uri-scheme uri)
 249       ":"
 250       (let ((auth (uri-authority uri)))
 251         (if auth
 252             (string-append "//" auth)
 253             ""))
 254       (uri-path uri)
 255       (maybe (uri-query uri) "?")
 256       (maybe (uri-fragment uri) "#"))))
 257
 258  (define authority->string
 259    (lambda (authority)
 260      (string-append
 261       (let ((user (authority-username authority)))
 262         (if user
 263             (string-append user "@")
 264             ""))
 265       (authority-host authority)
 266       (let ((port (authority-port authority)))
 267         (if port
 268             (string-append ":" (number->string port))
 269             "")))))
 270
 271  ;; Two authororities are equal if they're record values are equal.
 272  (define authority-equal?
 273    (lambda (auth1 auth2)
 274      (and (equal? (authority-username auth1)
 275                   (authority-username auth2))
 276           (equal? (authority-host auth1)
 277                   (authority-host auth2))
 278           (eqv? (authority-port auth1)
 279                 (authority-port auth2)))))
 280
 281  ;; Read chars while valid or eof-object?
 282  ;; Place valid chars in output string port
 283  ;; First invalid char is left on the input port
 284  ;; returns: number of valid chars read from input port.
 285
 286  (define read-valid
 287    (lambda (ip valid? op)
 288      (let loop ((ch (peek-char ip)) (cnt 0))
 289        (if (or (eof-object? ch)
 290                (not (valid? ch)))
 291            cnt
 292            (begin
 293              (write-char (read-char ip) op)
 294              (loop (peek-char ip) (fx1+ cnt)))))))
 295
 296  ;; (input-port?  output-port?) -> boolean?)
 297  ;; parse the "tail" of a scheme
 298  ;; i.e., the rest of the scheme string given that
 299  ;; the start char of the scheme was valid.
 300  ;; returns: # of chars read
 301  (define parse-scheme-tail
 302    (lambda (ip op)
 303      (read-valid ip scheme-tail-ch? op)))
 304
 305  (define parse-scheme
 306    (lambda (ip)
 307      (let ((op (open-output-string)))
 308        (let ((ch (peek-char ip)))
 309          (if (not (scheme-start-ch? ch))
 310              #f
 311              (begin
 312                (write-char (read-char ip) op)
 313                (parse-scheme-tail ip op)
 314                (get-output-string op)))))))
 315
 316
 317  ;; lex a character of value chtok
 318  ;; returns: #f if the next character is not a chtok
 319  (define (parse-char ip chtok)
 320    (let ((ch (peek-char ip)))
 321      (if (eof-object? ch)
 322          #f
 323          (if (eq? ch chtok)
 324              (begin
 325                (read-char ip)
 326                #t)
 327              #f))))
 328
 329  (define parse-authority-opaque
 330    (lambda (ip)
 331      (let ((op (open-output-string)))
 332        (read-valid ip (lambda (ch)
 333                         (case ch
 334                           ((#\/ #\? #\#) #f)
 335                           (else #t)))
 336                    op)
 337        (get-output-string op))))
 338
 339  (define parse-path-abempty
 340    (lambda (ip)
 341      (let ((op (open-output-string)))
 342        (let ((ch (peek-char ip)))
 343          (if (or (eof-object? ch)
 344                  (eq? ch #\?)
 345                  (eq? ch #\#))
 346              ""
 347              (if (not (eq? ch #\/))
 348                  (error "A URI with an authority can only have an absolute path.")
 349                  (begin
 350                    (write-char (read-char ip) op)
 351                    (let ((ch (peek-char ip)))
 352                      (if (eq? ch #\/)
 353                          (error "Absolute path must have a none empty segment.  i.e., // is illegal")
 354                          (read-valid ip
 355                                      (lambda (ch)
 356                                        (or
 357                                         (pchar? ch)
 358                                         (eq? ch #\/)))
 359                                      op))))))
 360          (get-output-string op)))))
 361
 362  (define parse-path-absolute
 363    (lambda (ip)
 364      (let ((op  (open-output-string)))
 365        (write-char #\/ op)
 366        ;; first segment must not have a ':'
 367        (read-valid ip
 368                    (lambda (ch)
 369                      (and
 370                       (not (eq? ch #\:))
 371                       (pchar? ch)))
 372                    op)
 373        (read-valid ip
 374                    (lambda (ch)
 375                      (or
 376                       (pchar? ch)
 377                       (eq? ch #\/)))
 378                    op)
 379        (get-output-string op))))
 380
 381  (define parse-path-rootless
 382    (lambda (ip)
 383      (let ((op (open-output-string)))
 384        (read-valid ip
 385                    (lambda (ch)
 386                      (or
 387                       (pchar? ch)
 388                       (eq? ch #\/)))
 389                    op)
 390        (get-output-string op))))
 391
 392  ;; returns 2 values
 393  ;;  1) authority or #f
 394  ;;  2) path
 395  (define parse-hier
 396    (lambda (ip)
 397      (let ((ch (peek-char ip)))
 398        (if (eof-object? ch)
 399            (values #f "")
 400            (if (eq? ch #\/)
 401                (begin
 402                  (read-char ip)
 403                  (if (eq? (peek-char ip) #\/)
 404                      (begin
 405                        (read-char ip)
 406                        (let ((authority (parse-authority-opaque ip)))
 407                          (let ((path-abempty (parse-path-abempty ip)))
 408                            (values authority path-abempty))))
 409                      (values #f (parse-path-absolute ip))))
 410                (values #f (parse-path-rootless ip)))))))
 411
 412  (define parse-query-or-fragment
 413    (lambda (ip signal-char)
 414      (let ((ch (peek-char ip)))
 415        (if (eof-object? ch)
 416            #f
 417            (if (eq? ch signal-char)
 418                (let ((op (open-output-string)))
 419                  (read-char ip) ;; consume signal char
 420                  (read-valid ip
 421                              (lambda (ch)
 422                                (or
 423                                 (pchar? ch)
 424                                 (eq? ch #\?)
 425                                 (eq? ch #\/)))
 426                              op)
 427                  (get-output-string op))
 428                #f)))))
 429
 430  (define parse-uri
 431    (lambda (uri-str)
 432      (let ((ip (open-string-input-port uri-str)))
 433        (let ((scheme (parse-scheme ip)))
 434          (if (not scheme)
 435              (error "Invalid URI.  manditory scheme is missing.")
 436              (if (not (parse-char ip #\:))
 437                  (error "Invalid URI.  scheme must be delimited by a ':'.")
 438                  (let-values (((authority path) (parse-hier ip)))
 439                    (let ((query (parse-query-or-fragment ip #\?)))
 440                      (let ((fragment (parse-query-or-fragment ip #\#)))
 441                        (ctor-uri scheme authority path query fragment))))))))))
 442
 443  ;; Parse out the port string.
 444  ;; Assumes leading ':' has been consumed.
 445  (define parse-port
 446    (lambda (ip)
 447      (let ((op  (open-output-string)))
 448        (if (or (eof-object? (peek-char ip))
 449                (not (digit-char? (peek-char ip))))
 450            (error "Missing port number or extraneous characters where port number was expected.")
 451            (let ((port (begin
 452                          (read-valid ip
 453                                      (lambda (ch)
 454                                        (digit-char? ch))
 455                                      op)
 456                          (get-output-string op))))
 457              (string->number port))))))
 458
 459 ;;; Parse the host and optional port from a given string
 460 ;;; returns: (values host port)
 461  (define parse-host-port
 462    (lambda (ip)
 463      (let ((op  (open-output-string)))
 464        (if (eof-object? (peek-char ip))
 465            (error "URI missing required host.")
 466            (let ((host (begin
 467                          (read-valid ip
 468                                      (lambda (ch)
 469                                        (or
 470                                         (unreserved-char? ch)
 471                                         (pct-encoded-char? ch)
 472                                         (sub-delim-char? ch)))
 473                                      op)
 474                          (get-output-string op))))
 475              (if (> (string-length host) 0)
 476                  (let ((ch (read-char ip)))
 477                    (if (eof-object? ch)  ;; no port
 478                        (values host #f)
 479                        (if (not (eq? ch #\:))
 480                            (error "Host must be optionally followed by a port.  Something else found.")
 481                            (let ((port (parse-port ip)))
 482                              (values host port)))))
 483                  (error "Manditory host is missing.")))))))
 484
 485  (define authority-with-username?
 486    (lambda (auth)
 487      (let ((ip (open-string-input-port auth)))
 488        (let loop ((ch (read-char ip)))
 489          (cond
 490           ((eof-object? ch) #f)
 491           ((eq? ch #\@) #t)
 492           (else
 493            (loop (read-char ip))))))))
 494
 495  (define parse-authority
 496    (lambda (auth-str)
 497      (if (not (string? auth-str))
 498          #f
 499          (let ((ip (open-string-input-port auth-str)))
 500            (if (authority-with-username? auth-str)
 501                (let ((op  (open-output-string)))
 502                  (read-valid ip
 503                              (lambda (ch)
 504                                (or
 505                                 (unreserved-char? ch)
 506                                 (pct-encoded-char? ch)
 507                                 (sub-delim-char? ch)
 508                                 (eq? ch #\:)))
 509                              op)
 510                  (if (not (eq? (read-char ip) #\@))
 511                      (error "Invalid username.")
 512                      (let ((username (get-output-string op)))
 513                        (let-values (((host port) (parse-host-port ip)))
 514                          (make-authority username host port)))))
 515                (let-values (((host port) (parse-host-port ip)))
 516                  (make-authority #f host port)))))))
 517
 518
 519  (rtd-printer-set! uri (lambda (uri outp)
 520                          (display "#<uri \"" outp)
 521                          (display (uri->string uri) outp)
 522                          (display "\">" outp)))
 523
 524  (rtd-printer-set! authority (lambda (auth outp)
 525                                (display "#<authority \"" outp)
 526                                (display (authority->string auth) outp)
 527                                (display "\">" outp)))
 528  )
 529
 530 (library
 531  (rl3 web uri url parms)
 532
 533  (export parse-parms encode-parm
 534          parms->query)
 535
 536  (import
 537   (rnrs base)
 538   (only (rnrs io simple)
 539         eof-object?)
 540   (only (rnrs io ports)
 541         open-string-input-port
 542         get-char put-char put-string)
 543   (only (rl3 web uri char-sets)
 544         encode-char unsafe-char?)
 545   (only (rl3 types chars)
 546         string->char-set
 547         char-set-complement)
 548   (only (rl3 types strings)
 549         string-tokenize)
 550   (only (rl3 text text)
 551         separate)
 552   (primitives get-output-string open-output-string))
 553
 554  (define parm-reserved-char?
 555    (lambda (ch)
 556      (case ch
 557        ((#\& #\=) #t)
 558        (else #f))))
 559
 560  (define alist? list?)
 561  (define query alist?)
 562
 563  (define encode-parm-string
 564    (lambda (str)
 565      (let ((op (open-output-string))
 566            (ip (open-string-input-port str)))
 567        (let loop ((ch (get-char ip)))
 568          (if (eof-object? ch)
 569              (get-output-string op)
 570              (begin
 571                (if (or (unsafe-char? ch)
 572                        (parm-reserved-char? ch))
 573                    (put-string op (encode-char ch))
 574                    (put-char op ch))
 575                (loop (get-char ip))))))))
 576
 577  (define encode-parm
 578    (lambda (parm)
 579      (let ((key   (car parm))
 580            (value (cdr parm)))
 581        (cons (encode-parm-string key)
 582              (encode-parm-string value)))))
 583
 584  (define parms->query
 585    (lambda (parms)
 586      (separate "&" (map (lambda (kv)
 587                           (string-append (car kv) "=" (cdr kv)))
 588                         parms))))
 589
 590  (define parm-delim-char-set
 591    (char-set-complement (string->char-set "=&")))
 592
 593  (define parse-parms
 594    (lambda (parm-str)
 595      (let ((kvs (string-tokenize parm-str parm-delim-char-set)))
 596        (let loop ((kvs kvs) (parms '()))
 597          (if (null? kvs)
 598              parms
 599              (let ((key (car kvs)))
 600                (if (null? (cdr kvs))
 601                    parms ;; odd number of KVs which is wrong.  Return what we got.
 602                    (loop (cddr kvs) (cons (cons key (cadr kvs)) parms)))))))))
 603
 604  )
 605
 606 ;;          (define test-auth
 607 ;;            (list
 608 ;;             "www.amazon.com"
 609 ;;             "ray@www.amazon.com"
 610 ;;             "www.amazon.com:80"
 611 ;;             "ray@www.amazon.com:80"))
 612
 613 ;;          (define test-auth-bad
 614 ;;            (list
 615 ;;             "ray@"
 616 ;;             "ray@80"
 617 ;;             ":90"
 618 ;;             "ray@:80"))
 619
 620 ;;          (for-each (lambda (auth-str)
 621 ;;                      (let ((auth (parse-authority auth-str)))
 622 ;;                        (display "Username: ")
 623 ;;                        (display (authority-username auth))
 624 ;;                        (display " Host: ")
 625 ;;                        (display (authority-host auth))
 626 ;;                        (display " Port: ")
 627 ;;                        (display (authority-port auth))
 628 ;;                        (newline)))
 629 ;;                    test-auth)
 630
 631
 632 ;; http://ecs.amazonaws.com/onca/xml?
 633 ;; Service=AWSECommerceService&
 634 ;; Operation=ItemSearch&
 635 ;; AWSAccessKeyId=[Access Key ID]&
 636 ;; AssociateTag=[ID]&
 637 ;; SearchIndex=Apparel&
 638 ;; Keywords=Shirt
 639
 640 ;; (uri->string (parse-uri (uri->string
 641 ;;                          (make-uri "http"
 642 ;;                                    "" "ecs.amazonaws.com" #f
 643 ;;                                    "/onca/xml"
 644 ;;                                    "Service=AWSECommerceService&Operation=ItemSearch&AWSAccessKeyId=[Access Key ID]&AssociateTag=[ID]&SearchIndex=Apparel&Keywords=Shirt"
 645 ;;                                    ""))))
 646
 647
 648 ;; (uri-authority (make-uri "http"
 649 ;;                          "" "ecs.amazonaws.com" 8080
 650 ;;                          "/onca/xml"
 651 ;;                          "Service=AWSECommerceService&Operation=ItemSearch&AWSAccessKeyId=[Access Key ID]&AssociateTag=[ID]&SearchIndex=Apparel&Keywords=Shirt"
 652 ;;                          "")) )