;; 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 the SXML layer, setting API response format parameters to xml and
; translating raw text/xml responses to sxml, and recognising and optionally handling API-level
; errors and warnings.
;
(module mw-sxml
; SXML interface to the MediaWiki API.
  (export sx-call make-sx-call sx-call-once sx-select generate-query sx-match-predicate
          sx-warnings? sx-error? sx-error-handler sx-warning-handler sx-warnings-strict
          sx-warnings-ignore)
  (import chicken scheme ports extras data-structures regex srfi-1 srfi-13)
  (require-extension uri-common intarweb http-client ssax sxpath mw-raw)

  (include "mw-macros.scm")

  (define sx-error-handler
    (make-parameter
     (lambda (loc parsed-result)
       (mw:error loc (string-append "Error in API call: "
                                    (->string ((sxpath "api/error/@info")
                                               parsed-result)))))))

  (define sx-warning-handler
    (make-parameter
     (lambda (loc parsed-result)
       parsed-result)))

  (define (sx-warnings-strict)
    (sx-warning-handler
     (lambda(loc parsed-result) (mw:error loc
                                          (string-append
                                           "warning in API call: "
                                           (->string ((sxpath "api/warnings/query/text()") parsed-result)))))))

  (define (sx-warnings-ignore)
    (sx-warning-handler (lambda(loc parsed-result) parsed-result)))

; This is a generic predicate for sxpath patterns.
  (define (sx-match-predicate match-string)
    (let ((select-proc (sxpath match-string)))
      (lambda (parsed-response)
        (let ((sxmatch (select-proc parsed-response)))
          (and sxmatch (not (null? sxmatch)) sxmatch)))))

; Use sx-match-predicate to construct pattern matches for warnings
; and errors.
  (define sx-warnings? (sx-match-predicate "api/warnings"))
  (define sx-error?    (sx-match-predicate "api/error"))

;; Check or an alist:
  (define (alist? x)
    (and (list? x)
         (let loop ((x x))
           (or (null? x)
               (and (pair? (car x))
                    (loop (cdr x)))))))


; This procedure uses raw-api-call to get the API response in xml format and then
; parses it into sxml, with configurable handling of API warnings and errors.
  (define (basic-sx-call parameters #!rest z #!key wiki method)
    (mw:check-arguments 'basic-sx-call z '(wiki method))
    (or (alist? parameters)
        (mw:error 'sx-call
                  (sprintf "error: parameters not an association list: ~S" parameters)))
    (and (assq 'format parameters)
         (error 'basic-sx-call "Parameter \"format\" should not be provided.  Format xml is to be selected internally by mw code."))
    (let ((parsed-result
           (call-with-input-string (raw-api-call (cons '(format . xml) parameters)
                                                 wiki: wiki
                                                 method: method)
                                   (lambda(p)(ssax:xml->sxml p '())))))
      (cond
       ((sx-error? parsed-result)
        ((sx-error-handler) 'basic-sx-call parsed-result))
       ((sx-warnings? parsed-result)
        ((sx-warning-handler) 'basic-sx-call parsed-result))
       (else parsed-result))))

  (define continue-selector (sxpath "api/query-continue/*/@*"))

; This pattern detects generator continue clauses, which are only to be used when there
; is no other continue clause.
  (define caretg-regexp (regexp "^g" #t))

;
; This procedure uses basic-sx-call repeatedly to fetch continued queries.
;
  (define (sx-call parameters #!rest z #!key wiki method)
    (mw:check-arguments 'sx-call z '(wiki method))
    (let loop ((result-list '()) (result (basic-sx-call parameters
                                                           wiki: wiki
                                                           method: method)))
      (if (null? result)
          (reverse result-list)
          ;; Selects a list of 1 or 2 continue clauses (maybe 2 if generator used,
          ;; always 1 if no generator used; null list if no more data).
          (let ((continue (continue-selector result)))
            (loop (cons result result-list)
                  (if (null? continue) '()
                      ;; If more than one continue clause, filter out the generator
                      ;; continue clause.  It's only to be used if it's on its own.
                      (let ((continue (if (> (length continue) 1)
                                          (filter (lambda(x)
                                                    (not (string-search caretg-regexp
                                                                        (->string (car x)))))
                                                  continue)
                                          continue)))
                        (basic-sx-call
                         (cons (cons (caar continue)
                                     (cadar continue)) parameters)
                         wiki: wiki
                         method: method))))))))

  (define (make-sx-call parameters #!rest z #!key wiki method)
    (mw:check-arguments 'make-sx-call z '(wiki method))
    (let ((continue #f)
          (finished #f))
      (lambda ()
        (if finished '()
            (let* ((result (basic-sx-call
                            (if continue
                                (cons (cons (caar continue)
                                            (cadar continue)) parameters)
                                parameters)
                            wiki: wiki
                            method: method))
                   (cont (continue-selector result)))
              (set! continue (if (null? cont) #f
                                 (if (> (length cont) 1)
                                     (filter (lambda(x)
                                               (not (string-search caretg-regexp
                                                                   (->string (car x)))))
                                             cont)
                                     cont)))
              (set! finished (not continue))
              result)))))

  (define (sx-call-once parameters #!rest z #!key wiki method)
    (mw:check-arguments 'sx-call-once z '(wiki method))
    ((make-sx-call parameters wiki: wiki method: method)))

  (define (sx-select result data-selectors)
    (let ((data-selectors (map
                           (lambda (x) (if (procedure? x) x (sxpath x)))
                           (if (list? data-selectors) data-selectors (list data-selectors)))))
      (apply map list
             (map
              (lambda (data-selector)
                (concatenate
                 (map data-selector result)))
              data-selectors))))

  (define (generate-query source query)
    (cond
     ((and (pair? source)
           (memq (car source) '(titles revids pageids)))
      (let ((name (car source))
            (body (cdr source)))
        (append `((,name . ,(pipify body))) query)))
     ((and (pair? source) (pair? (car source)))
      (let ((lst (or (assoc 'list source) (assoc 'prop source))))
        (if (pair? lst)
            (let ((generator
                   (filter-true
                    (map
                     (lambda(x)
                       (case (string->symbol (->string (car x)))
                         ((list prop) `(generator . ,(cdr x)))
                         ((action) #f)
                         (else
                          (cons (string-append "g" (->string (car x))) (cdr x)))))
                     source))))
              (append generator query)))))
     (else  (append query `((titles . ,(pipify source)))))))
  )