Welcome to the CHICKEN Scheme pasting service

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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)))))

)