#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; XML.plt - XML related utility
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; port.ss - bindings for reading html or xml into xexpr or sxml
;; yc 12/22/2009 - first version
;; yc 1/18/2009 - fix the read-sxml and read-xexpr's signature to expect only 1 arg
(require html
         xml
         (planet bzlib/http)
         (planet bzlib/base)
         "xml.ss" 
         (rename-in (planet lizorkin/sxml) (srl:sxml->xml-noindent sxml->string))
         )

(define (single-element? contents)
  (= 1 (length (filter xexpr? contents))))

;; html->xexpr
(define (html->xexpr contents)
  (let ((contents (map xml->xexpr contents)))
    (cond ((single-element? contents)
           (car contents))
          (else
           `(*TOP* . ,contents)))))

(define (http-content-type-helper response)
  (define (helper s)
    (if s (cdr s) ""))
  (helper (assf (lambda (key)
                  (string-ci=? "Content-Type" key)) 
                (http-client-response-headers response))))

(define (read-xexpr in (filter identity))
  (define (helper content-type)
    (filter (if (string-ci=? content-type "text/xml")
                (xml->xexpr (document-element (read-xml in)))
                (html->xexpr (read-html-as-xml in)))))
  (helper (if (http-client-response? in)
              (http-content-type-helper in)
              "text/html")))

(define (read-sxml in (filter identity)) 
  (xexpr->sxml (read-xexpr in filter))) 

(define (write-xexpr xexpr (out (current-output-port))) 
  (write-string (xexpr->string xexpr) out)) 

(define (write-sxml sxml (out (current-output-port))) 
  (write-string (sxml->string sxml) out)) 

(define xexpr/c* any/c)
(define sxml/c any/c)

(provide/contract
 (read-xexpr (->* (input-port?) 
                  ((-> any/c any)) any)) ;; xexpr?
 (read-sxml (->* (input-port?) 
                 ((-> any/c any)) any))
 (write-xexpr (->* (xexpr/c*)
                   (output-port?)
                   any))
 (write-sxml (->* (sxml/c)
                  (output-port?)
                  any))
 )

(provide sxml->string)