;; Copyright (c) 2007,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 builds on the sxml layer provided by mw-sxml and provides a more
; scheme-like interface to a number of useful everyday tasks such as listing
; page contents, revision histories, category member lists, backlinks and
; transclusions, and checking user group membership (privileges).
;
(module mw-edit
  (export ignore-semantics login logout edit watch unwatch)
  ;;; TODO: Finish writing send-email.  Remember to add it to exports both here
  ;;; and in the export in mw.scm.

  (import chicken scheme data-structures srfi-1 srfi-13 regex)
  (require-extension sxpath mw-raw mw-sxml)
  (include "mw-macros.scm")

  (define ignore-semantics (make-parameter '()))

  (define login
    (let ((sxresult (sxpath "api/login/@result")))
      (lambda (credentials #!key wiki)
        (let* ((wiki (or wiki (default-wiki))))
          (receive (username password)
              (credentials wiki)
            (let* ((login-response (sx-call `((action . login)
                                              (lgname . ,username)
                                              (lgpassword . ,password))
                                            wiki: wiki method: 'POST))
                   (result (cadar (sxresult login-response))))
              (if (string=? result "Success")
                  login-response
                  (mw:error 'login (sprintf "Result of login: ~S" result)))))))))
               
        
  (define (logout #!key wiki method)
    (let* ((wiki (or wiki (default-wiki)))
           (method (or method (default-method))))
      (sx-call '((action . logout))
               wiki: wiki method: method)))

  (define sxtoken (sxpath "api/query/pages/page/@edittoken"))
  (define sxtimestamp (sxpath "api/query/pages/page/revisions/rev/@timestamp"))

  (define (edit title #!key
                section text appendtext prependtext summary minor notminor bot
                recreate createonly nocreate watchlist md5 captchaid captchaword
                undo undoafter wiki)
    ; Semantics
    (if (not (memq 'edit (ignore-semantics)))
        (begin
          (or title (mw:error 'edit "No page title"))
          (or (string? title) (symbol? title)
              (mw:error 'edit "Page title must be a string or symbol"))
          (or text prependtext appendtext undo
              (mw:error
               'edit "One of the parameters text, prependtext, appendtext and undo must be set"))
          (and minor notminor (mw:error 'edit "Both minor and notminor flags were set"))
          (and createonly nocreate (mw:error 'edit "Both creatonly and nocreate flags were set"))
          (and recreate nocreate (mw:error 'edit "Both recreate and nocreate flags were set"))
          (and undoafter (not undo) (mw:error 'edit "Undoafter set but undo not given"))
          (and captchaword (not captchaid)
               (mw:error 'edit "captchaword given but capthaid not given"))))
    (let* ((wiki (or wiki (default-wiki)))
           (response (sx-call `((action . query)
                                (titles . ,title)
                                (prop . ,(pipejoin '(info revisions)))
                                (intoken . edit))
                              wiki: wiki method: (default-method)))
           (edittoken (sxtoken response))
           (timestamp (sxtimestamp response))
           (notrecreate (not recreate)))
      (and (pair? edittoken) (set! edittoken (cadar edittoken)))
      (and (pair? timestamp) (set! timestamp (cadar timestamp)))
      (sx-call
       (filter-true
        `((action . edit)
          (title . ,title)
          ,(and-. section section)
          ,(and-. text text)
          ,(and-. prependtext prependtext)
          ,(and-. appendtext appendtext)
          (token . ,edittoken)
          ,(and-. summary summary)
          ,(and-. minor minor)
          ,(and-. notminor notminor)
          ,(and-. bot bot)
          (basetimestamp . ,timestamp)
          ,(and-. starttimestamp timestamp (not recreate))
          ,(and-. recreate recreate)
          ,(and-. createonly createonly)
          ,(and-. nocreate nocreate)
          ,(and-. watchlist watchlist)
          ,(and-. md5 md5)
          ,(and-. captchaid captchaid)
          ,(and-. captchaword captchaword)
          ,(and-. undo undo)
          ,(and-. undoafter undoafter)))
       wiki: wiki method: 'POST)))

  (define (watch/unwatch unwatch page #!key wiki method)
    (let ((wiki (or wiki (default-wiki)))
          (method (or method (default-method))))
      (sx-select
       (sx-call `((action . watch)
                  (title . ,page)
                  (unwatch . ,unwatch))
                wiki: wiki method: method)
       `("api/watch/@title"
         ,(string-append "api/watch/@" (if unwatch "unwatched" "watched"))))))

  (define watch (lambda x (apply watch/unwatch #f x)))
  (define unwatch (lambda x (apply watch/unwatch #t x)))

  #;(define (send-email user summary contents #!key wiki)
    (let ((email-token-reply
           (sx-select
            (sx-call `((action . query)
                       (titles . ,(string-append "User:" user))
                       (prop . info)
                       (intoken . email))
                     wiki: wiki method: 'POST)
            "api/query/pages/page/@emailtoken")))
      email-token-reply)))