;; Copyright (c) 2009, Tony Sidaway
;; 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.
;
; This module provides common functions.  The lowest API access layer, it sends API commands,
; returning raw text responses. Also provided are parameters to set the default behavior
; such as the default wiki, default method and default headers.  There is also an error
; handling procedure and a function to handle the translation of list parameters to
; pipe-delimited strings.
;
(module mw-raw
  (export mw:error raw-api-call default-method default-wiki default-headers
          default-headers-gzip default-headers-none wikipedia wikibooks wikiquote
          wikisource pipejoin mw:check-arguments)
  (import chicken scheme data-structures ports extras posix srfi-13 srfi-18)
  (require-extension uri-common intarweb http-client z3)

; Need this because MediaWiki doesn't handle the default semicolon separator
  (form-urlencoded-separator "&")

; Default method.  May be changed but has a reasonable default.
  (define default-method (make-parameter 'GET))

; A default wiki must be defined, or else the wiki keyword
; must be provided in every call.
  (define default-wiki (make-parameter #f))

; Default headers: accept gzip encoding.
  (define default-headers (make-parameter '((accept-encoding . (gzip)))))

; Procedures to set default-headers to commonly-used values.
  (define (default-headers-gzip) (default-headers '((accept-encoding . (gzip)))))
  (define (default-headers-none) (default-headers '()))

; Raise an error condition
  (define (mw:error loc msg . rest)
    (raise (make-composite-condition
            (make-property-condition 'exn 'location loc 'message msg)
            (make-property-condition 'mw:error)
            (apply make-property-condition 'specific rest))))

  (define (read-big-long-string p)
    (let loop ((size 256)(lst '()) (s (read-string 128 p)))
      (if (= (string-length s) 0)
          (apply string-append (reverse lst))
          (loop (* size 2) (cons s lst) (read-string size p)))))

  (define (decode-rfc1952 buffer)
    (receive (file-descriptor temporary-file)
	(file-mkstemp "/tmp/mw_raw_rfc1952.XXXXXX")
      (let ((temporary-write-port (open-output-file* file-descriptor))
            (buffer-length-minus-1 (- (string-length buffer) 1)))
        ;;; Some servers send a carriage return after the gzip input stream, and
        ;;; this confuses decoders such as the GNU gzip and Chicken's z3 egg.
        ;;; Search for it and remove it if found.
	(display (if (char=? (string-ref buffer buffer-length-minus-1) #\return)
                     (substring buffer 0 buffer-length-minus-1)
                     buffer)
                 temporary-write-port)
	(close-output-port temporary-write-port)
	(let* ((compressed-input-port (z3:open-compressed-input-file temporary-file))
	       (decoded-file-content (read-big-long-string compressed-input-port)))
	  (close-input-port compressed-input-port)
	  (delete-file temporary-file)
	  decoded-file-content))))
#|
  This procedure takes API parameters, sends them to the wiki using the desired
  method, and returns the response as a string.  Remember to include a "format"
  parameter to indicate how you want the results formatted.

  gzip content encoding is accepted and handled by this procedure using the
  decode-rfc1952 procedure defined above.
|#
  (define (raw-api-call parameters #!rest z #!key wiki method)
    (mw:check-arguments 'raw-api-call z '(wiki method))
    (let ((wiki (or wiki (default-wiki)))
          (method (or method (default-method))))
      (or (eqv? method 'POST) (eqv? method 'GET)
          (mw:error 'raw-api-call
                    (sprintf "error: method ~S is neither GET nor POST"
                             method)))
      (or wiki (mw:error 'raw-api-call
                         "initialization error: (default-wiki) has not been initialized"))
      (or (list? parameters)
          (mw:error 'raw-api-call
                    (sprintf "error: parameters not a list: ~S" parameters)))
      (let ((request
             (make-request uri: (update-uri (uri-reference wiki)
                                            query: (and (eq? method 'GET)
                                                        parameters))
                           headers: (headers (default-headers))
                           method: method))
            (writer
             (and (eq? method 'POST) parameters)))
        (receive (reader-result uri response)
            (call-with-input-request request writer (lambda(p) (read-big-long-string p)))
          (let ((content-encoding (header-value 'content-encoding (response-headers response))))
            (case content-encoding
              ((gzip) (decode-rfc1952 reader-result))
              (else reader-result)))))))

  (define (wiki type)
    (let ((domain
           (case type
             ((wp) "wikipedia.org/w")
             ((wb) "wikibooks.org/w")
             ((wq) "wikiquote.org/w")
             ((ws) "wikisource.org/w")
             (else #f))))
      (lambda maybe-xx
        (let ((xx (if (null? maybe-xx) "en" (car maybe-xx))))
          (string-append "http://" xx "." domain "/api.php")))))

  (define wikipedia (wiki 'wp))
  (define wikibooks (wiki 'wb))
  (define wikiquote (wiki 'wq))
  (define wikisource (wiki 'ws))

;;
;; pipejoin: useful function to turn lists of stuff into pipe-separated strings
;; expected by the API.
;;
  (define (pipejoin x)
    (cond ((list? x) (string-join (map ->string x) "|"))
          ((vector? x) (string-join (map ->string (vector->list x)) "|"))
          (else (->string x))))

;;
;; mw:check-arguments. Check for bad

  (define (mw:check-arguments loc z keys)
    (let ((keys (map ->string keys)))
      (let loop ((z z))
        (and (pair? z)
             (if (member (->string (car z)) keys)
                 (if (pair? (cdr z))
                     (loop (cddr z))
                     (mw:error loc (sprintf "Keyword ~s without value" (car z))))
                 (mw:error loc (sprintf "Unexpected argument or arguments ~s~%" z))))))) )