#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MIME.plt
;;
;; an extensible MIME framework.
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; content-type.ss - reader/writer for content-type
;; yc 2/18/2010 - first version.
(require "base.ss" 
         "depend.ss"
         )

(define-struct (content-type kvs) (base sub))

(define (content-type/full ct)
  (format "~a/~a" (content-type-base ct)
          (content-type-sub ct))) 

(define (normalize-params params)
  ;; the helpers address combining of the MIME parameter continuations
  ;; as defined in RFC 2331 - http://tools.ietf.org/html/rfc2231
  (define (normalize-param-name name) 
    (let ((match (regexp-match #px"([^\\*])+\\*(\\d+)" name)))
      (if (not match)
          (cons name -inf.0)
          (cons (cadr match) (caddr (string->number match))))))
  (define (continue-parameter-helper rest ordered name acc)
    (cond ((null? rest) 
           (reverse (cons (cons name (string-join (reverse acc) "")) ordered)))
          ((string-ci=? (caaar rest) name) 
           (continue-parameter-helper (cdr rest) ordered
                                      name 
                                      (cons (cdar rest) acc)))
          (else ;; we are done...
           (parameter-order-helper rest
                                   (cons (cons name (string-join (reverse acc) ""))
                                         ordered)))))
  (define (parameter-order-helper rest ordered)
    (cond ((null? rest) (reverse ordered))
          ((eq? -inf.0 (cdaar rest)) 
           (parameter-order-helper (cdr rest) 
                                   (cons (cons (caaar rest) (cdar rest)) ordered)))
          (else ;; we are matching
           (continue-parameter-helper (cdr rest) 
                                      ordered
                                      (caaar rest)
                                      (list (cdar rest))))))
  (parameter-order-helper (sort (map (lambda (kv)
                                       (cons (normalize-param-name (car kv))
                                             (cdr kv)))
                                     params)
                                (lambda (p1 p2) 
                                  (let ((n1 (car p1))
                                        (n2 (car p2)))
                                    (or (string-ci<? (car n1) (car n2))
                                        (< (cdr n1) (cdr n2))))))
                          '()))

(define (build-content-type type params)
  (define (helper base sub params)
    (make-content-type (normalize-params params)
                       (string-downcase base)
                       (string-downcase sub)))
  (if-it (regexp-match #px"^([^\\/]+)\\/([^\\/]+)$" type)
         (helper (cadr it) (caddr it) params)
         (helper "text" "plain" params)))

;; the simplest is not to have any sort of *translation* of the data types...
;; we can for certain handle the conversion of the
(define p:parameter (tokens/comment key <- p:atom 
                                  #\= 
                                  value <- p:param-value 
                                  (return (cons key value))))

(define (content-type-value maker)
  (tokens/comment type <- p:atom 
                  params <-
                  (zero-one (tokens/comment #\;
                                            params <- 
                                            (make-kvs-parser p:atom #\= 
                                                             p:param-value #\;)
                                            (zero-one #\; #\;)
                                            (return params))
                            '())
                  (return (maker type params))))

;; based on the headers we want to have enough information to *parse* in an
;; entity.
(define read-content-type (make-reader (content-type-value build-content-type)))

(define (write-content-type ct (type content-type/full))
  ;; how to customize kvs->string???
  (format "~a; ~a" 
          (type ct)
          (kvs->string ct #:one (lambda (kv) 
                                  (kv->string kv #:encode-val encode-param-value)))))

(define content-type/default
  (read-content-type "text/plain; charset=us-ascii;"))

(mime-header-reader-set! "Content-Type" read-content-type)

(string-converter-set! content-type? write-content-type)

(define content-type-reader-registry (make-kvs-registry '()))

;; we need to first make it a ref based on the type of the text...
(define (read-by-content-type in headers) 
  (let ((reader (registry-ref content-type-reader-registry
                              (content-type/full (kvs/list-ref headers 
                                                               "Content-Type"
                                                               content-type/default)) 
                              #f)))
    (if (procedure? reader)
        (reader (if (input-port? in) 
                    in
                    (open-input-abytes in)))
        in)))
;; (trace read-by-content-type)

(define (content-type-reader-set! type reader)
  (registry-set! content-type-reader-registry type reader)) 

(define (content-type-reader-del! type)
  (registry-del! content-type-reader-registry type)) 

(define content-type->input-registry (make-cond-registry '()))

(define (content-type->input data)
  ((registry-ref content-type->input-registry 
                 data 
                 (lambda (data)
                   (error 'content-type->input "unknown type: ~a")))
   data))

(define (content-type->input-set! type ->input) 
  (registry-set! content-type->input-registry type ->input)) 

(define (content-type->input-del! type)
  (registry-del! content-type->input-registry type)) 

(content-type->input-set! string? open-input-abytes)

(content-type->input-set! bytes? open-input-abytes)

(provide/contract 
 (struct content-type ((inner any/c)
                       (base any/c)
                       (sub any/c)))
 (p:parameter Parser/c)
 (read-content-type Reader/c)
 (content-type-value (-> procedure? Parser/c))
 (write-content-type (->* (kvs/list?) 
                          ((-> kvs/list? any))
                          string?))
 (content-type/full (-> content-type? string?))
 (content-type/default content-type?)
 (build-content-type (-> string? kvs/list? kvs?))
 (read-by-content-type (-> (or/c string? bytes? input-port?) kvs/list? any))
 (content-type-reader-set! (-> string? procedure? any))
 (content-type-reader-del! (-> string? any))
 (content-type->input (-> any/c input-port?))
 (content-type->input-set! (-> procedure? procedure? any)) 
 (content-type->input-del! (-> procedure? any))
 )