~rhcarvalho/+junk/racket

#lang racket

;; Explorations with decoding URLs %-encoded in Latin-1 rather than UTF-8

;;

;; Rodolfo Carvalho

(require net/url)

;; Portions of code taken from uri-codec-unit.rkt from the net/uri-codec collect.

;; ------------------------------------------------------------------

(define (self-map-char ch) (cons ch ch))

(define (self-map-chars str) (map self-map-char (string->list str)))

;; The characters that always map to themselves

(define alphanumeric-mapping

  (self-map-chars

   "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"))

;; Characters that sometimes map to themselves

;; called 'mark' in RFC 3986

(define safe-mapping (self-map-chars "-_.!~*'()"))

;; The strict URI mapping

(define uri-mapping (append alphanumeric-mapping safe-mapping))

;; ------------------------------------------------------------------

(define (number->hex-string number)

  (define (hex n) (string-ref "0123456789ABCDEF" n))

  (string #\% (hex (quotient number 16)) (hex (modulo number 16))))

(define (hex-string->number hex-string)

  (string->number (substring hex-string 1 3) 16))

(define ascii-size 128)

;; ------------------------------------------------------------------

;; (listof (cons char char)) -> (values (vectorof string) (vectorof string))

(define (make-codec-tables alist)

  (let ([encoding-table (build-vector ascii-size number->hex-string)]

        [decoding-table (build-vector ascii-size values)])

    (for-each (match-lambda

               [(cons orig enc)

                (vector-set! encoding-table

                             (char->integer orig)

                             (string enc))

                (vector-set! decoding-table

                             (char->integer enc)

                             (char->integer orig))])

              alist)

    (values encoding-table decoding-table)))

(define-values (uri-encoding-vector uri-decoding-vector)

  (make-codec-tables uri-mapping))

;; ------------------------------------------------------------------

;; vector string -> string

(define (decode table str)

  (define internal-decode

    (match-lambda [(list) (list)]

                  [(list* #\% (? hex-digit? char1) (? hex-digit? char2) rest)

                   ;; This used to consult the table again, but I think that's

                   ;;  wrong. For example %2b should produce +, not a space.

                   (cons (string->number (string char1 char2) 16)

                         (internal-decode rest))]

                  [(cons (? ascii-char? char) rest)

                   (cons (vector-ref table (char->integer char))

                         (internal-decode rest))]

                  [(cons char rest)

                   (append

                    (bytes->list (string->bytes/utf-8 (string char)))

                    (internal-decode rest))]))

  (bytes->string/latin-1 (apply bytes (internal-decode (string->list str)))))

(define (ascii-char? c)

  (< (char->integer c) ascii-size))

(define (hex-digit? c)

  (or (char<=? #\0 c #\9)

      (char<=? #\a c #\f)

      (char<=? #\A c #\F)))

;; string -> string

(define (uri-decode str)

  (decode uri-decoding-vector str))

;; ------------------------------------------------------------------

(define (force-utf-8/bytes bstr)

  (define c (bytes-open-converter "ISO-8859-1" "UTF-8"))

  (define-values (result-bstr src-read-amt status) (bytes-convert c bstr))

  (bytes-close-converter c)

  result-bstr)

(define (force-utf-8/string str)

  (define in (open-input-string str))

  (reencode-input-port in "ISO-8859-1")

  (port->string in))

(define current-url (string->url "http://www.ufrj.br"))

(define resource "http://www.ufrj.br/editais.php?tp=Acad%EAmicos&no=Cursos&idtp=4")

;(combine-url/relative current-url resource)

(uri-decode resource)