;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Data-URI (RFC 2397) decoder ;;; ;;; Copyright (C) 2013, Philip Kent ;;; Based on the URI-data egg, Copyright (c) 2008-2012, Peter Bex ;;; All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions are met: ;;; ;;; Redistributions of source code must retain the above copyright notice, this ;;; list of conditions and the following disclaimer. ;;; Redistributions in binary form must reproduce the above copyright notice, ;;; this list of conditions and the following disclaimer in the documentation ;;; and/or other materials provided with the distribution. ;;; Neither the name of the author nor the names of its contributors may be ;;; used to endorse or promote products derived from this software without ;;; specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" ;;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE ;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE ;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF ;;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ;;; POSSIBILITY OF SUCH DAMAGE. ;;; ;;; Philip Kent , 07/08/2013 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (provide 'uri-data) (module uri-data (uri-reference uri? uri->list uri->string make-uri update-uri uri-mimetype uri-encoding uri-data uri-base64 uri-encode-string uri-decode-string) (import chicken scheme) (require-extension srfi-1 extras data-structures defstruct base64) (require-library uri-generic) (import (prefix uri-generic generic:)) ;; A common URI is a generic URI plus stored decoded versions of most components (defstruct URI-data mimetype encoding base64 data) (define-record-printer (URI-data x out) (fprintf out "#" (URI-data-mimetype x) (URI-data-encoding x) (URI-data-base64 x) (URI-data-data x))) (define uri? URI-data?) ;; Decode a string into a data URI (define (uri-reference u) (assert (string? u) "uri-reference must recieve string") (let* ((u (string-split u ":")) (_ (assert (eqv? 'data (string->symbol (first u))) "Not a data URI")) (data (if (= (length u) 2) (string-split (last u) ",") "")) (data (if (= (length u) 2) (last data) "")) (u (string-split (last u) ","))) (define base64 #f) (define mimetype 'text/plain) (define encoding 'US-ASCII) (if (= (length u) 2) (let* ((u (first u)) (u (string-split u ";"))) (for-each (lambda (s) (if (eqv? 'base64 (string->symbol s)) (define base64 #t) (begin (let* ((s (string-split s "="))) (if (and (= (length s) 2) (eqv? 'encoding (string->symbol (first s)))) (define encoding (string->symbol (last s)))) (if (and (= (length s) 1) (= (length (string-split (first s) "/")) 2)) (define mimetype (string->symbol (first s)))))))) u))) (make-URI-data base64: base64 encoding: encoding mimetype: mimetype data: (decode-data base64 data)))) (define (uri->list uri) (list `(mimetype . ,(uri-mimetype uri)) `(encoding . ,(uri-encoding uri)) `(base64 . ,(uri-base64 uri)) `(data . ,(encode-data uri)))) (define (uri->string uri-in) (let* ((uri (list "data:")) (uri (if (uri-mimetype uri-in) (append uri (list (symbol->string (uri-mimetype uri-in)))) uri)) (uri (if (uri-encoding uri-in) (if (= (length uri) 1) (append uri (list (conc "encoding=" (symbol->string (uri-encoding uri-in))))) (append uri (list (conc ";encoding=" (symbol->string (uri-encoding uri-in)))))) uri)) (uri (if (uri-base64 uri-in) (if (= (length uri) 1) (append uri (list "base64")) (append uri (list ";base64"))) uri)) (uri (if (uri-data uri-in) (if (= (length uri) 1) (append uri (list (encode-data uri-in))) (append uri (list (conc "," (encode-data uri-in))))) uri))) (fold conc "" (reverse uri)))) ;;; Accessors and predicates (define uri-mimetype URI-data-mimetype) (define uri-encoding URI-data-encoding) (define uri-base64 URI-data-base64) (define uri-data URI-data-data) ;;; Constructor (define make-uri make-URI-data) ;;; Updaters (define update-uri (let ((unset (list 'unset))) (lambda (uc #!key (mimetype unset) (encoding unset) (base64 unset) (data unset)) ;; This code is ugly! (unless (eq? mimetype unset) (assert (symbol? mimetype) "mimetype not a symbol") (URI-data-mimetype-set! uc mimetype)) (unless (eq? encoding unset) (assert (symbol? encoding) "encoding not a symbol") (URI-data-encoding-set! uc encoding)) (unless (eq? base64 unset) (assert (boolean? base64) "base64 not a boolean") (URI-data-base64-set! uc base64)) (unless (eq? data unset) (URI-data-data-set! uc data))))) (define uri-encode-string generic:uri-encode-string) (define uri-decode-string generic:uri-decode-string) (define (encode-string* s) (and s (apply uri-encode-string s))) (define (decode-string* s) (and s (apply uri-decode-string s))) (define (encode-data uri) (let ((base64 (URI-data-base64 uri)) (data (URI-data-data uri))) (assert (string? data) "data not a string") (cond (base64 (base64-encode data)) ((not base64) (encode-string* (list data)))))) (define (decode-data base64 data) (assert (string? data) "data not a string") (cond (base64 (base64-decode data)) ((not base64) (decode-string* (list data))))) )