;; 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-query
  (export page-content page-revisions page-embeddedin categorymembers page-backlinks
          user-details l-user-groups user-group? make-user-group-predicate user-accountcreator?
          user-abusefilter? user-autoreviewer? user-boardvote? user-bot? user-bureaucrat?
          user-checkuser? user-confirmed? user-developer? user-founder? user-import?
          user-ipblock-exempt? user-oversight? user-rollbacker? user-steward? user-sysop?
          user-transwiki? user-exists?)

  (import chicken scheme data-structures srfi-1 srfi-13 regex)
  (require-extension sxpath mw-raw mw-sxml mw-format)
  (include "mw-macros.scm")
;;
;; page-content: get the present content of one or more pages.
;;
  (define (page-content pages #!key wiki method)
    (sx-select
     (sx-call `((action . query)
                (prop . revisions)
                (titles . ,(pipejoin pages))
                (rvprop . content))
              wiki: wiki method: method)
     '("//@title" "//text()")))
;;
;; page-revisions: generic revision lister for single pages
;;
  (define (page-revisions page #!key
                          (rvprop '("ids" "user" "timestamp" "content"))
                          rvstartid rvendid rvstart rvend rvdir rvuser
                          rvexcludeuser rvexpandtemplates rvsection
                          rvtoken wiki method)
    (sx-call 
     (filter-true
      `((action . query)
        (prop . revisions)
        (rvlimit . max)
        (titles . ,page)
        (rvprop . ,(pipejoin rvprop))
        ,(and-. rvstartid rvstartid)
        ,(and-. rvendid rvendid)
        ,(and-. rvstart rvstart)
        ,(and-. rvend rvend)
        ,(and-. rvdir rvdir)
        ,(and-. rvuser rvuser)
        ,(and-. rvexcludeuser rvexcludeuser)
        ,(and-. rvexpandtemplates rvexpandtemplates)
        ,(and-. rvsection rvsection)
        ,(and-. rvtoken rvtoken)))
     wiki: wiki method: method))
;;
;; page-embeddedin: pages that transclude a page
;;
  (define (page-embeddedin pages #!key
                           geinamespace geinamespace geifilterredir rvexpandtemplates
                           rvsection rvtoken
                           (rvprop 'content)
                           wiki method)
    (sx-call 
     (filter-true
      `((action . query)
        (generator . embeddedin)
        (geititle . ,(pipejoin pages))
        (geilimit . max)
        ,(and-. geinamespace geinamespace)
        ,(and-. geifilterredir geifilterredir)
        (prop . revisions)
        (rvprop . ,rvprop)
        ,(and-. rvexpandtemplates rvexpandtemplates)
        ,(and-. rvsection rvsection)
        ,(and-. rvtoken rvtoken)))
     wiki: wiki method: method))
  ;;
;; categorymembers: members of a category
;;
  (define (categorymembers category #!key
                           cmnamespace cmstart cmend cmstartsortkey cmendsortkey
                           cmsort cmdir cmprop wiki method)
    (let ((category-specification
           (if (string-search '(: bos (w/nocase "category:")) category)
               category
               (string-append "Category:" category))))
      (sx-call
       (filter-true
        `((action . query)
          (list . categorymembers)
          (cmlimit . max)
          (cmtitle . ,category-specification)
          ,(and-. cmnamespace cmnamespace)
          ,(and-. cmstart cmstart)
          ,(and-. cmend cmend)
          ,(and-. cmstartsortkey cmstartsortkey)
          ,(and-. cmendsortkey cmendsortkey)
          ,(and-. cmsort cmsort)
          ,(and-. cmdir cmdir)
          ,(and-. cmprop cmprop)))
       wiki: wiki method: method)))
;;
;; page-backlinks: what links here
;;
  (define (page-backlinks page #!key blnamespace blfilterredir blredirect wiki method)
    (sx-call
     (filter-true
      `((action . query)
        (list . backlinks)
        (bltitle . ,page)
        (bllimit . max)
        ,(and-. blnamespace blnamespace)
        ,(and-. blfilterredir blfilterredir)
        ,(and-. blredirect blredirect)))
     wiki: wiki method: method))
;;
;; unmemoized-user-details: details of a user
;;
  (define sxname (sxpath "api/query/allusers/u/@name"))
  (define (unmemoized-user-details username #!key wiki)
    ;;
    ;;    This API call "allusers" is really intended to return a list
    ;;    of users and "aufrom" is only advice on where to start.  Now this
    ;;    means that it returns a continue element which would be
    ;;    interpreted by sx-call in such a way as to cause it to
    ;;    exhaustively drag in the rest of the username list.  Since
    ;;    we don't want to do that, the strategy used here is to
    ;;    use make-sx-call to produce a closure that drags in just
    ;;    one username record on each call, and then call it just once.
    ;;    Another thing that needs to be done is to check that the
    ;;    username record returned really does match the username
    ;;    we gave as "aufrom", because if the username doesn't exist
    ;;    the API will quite happily return an unconnected record that
    ;;    just happens to be the next user in the username collation
    ;;    sequence.
    ;;
    (let* ((c-username (canonical-username username))
           (get-user-details (make-sx-call `((action . query)
                                             (list . allusers)
                                             (aufrom . ,c-username)
                                             (aulimit . 1)
                                             (auprop . ,(pipejoin '(groups editcount registration))))
                                           wiki: wiki))
           (user-details (get-user-details)) ; Get just 1 record.
           (name (sxname user-details)))
          ;;
          ;; Check that the name in the record returned is the same as the
          ;; one requested (aufrom is only advice to allusers on where to
          ;; start).  If so return the list of groups.
          ;;
          (and (not (null? name))
               (string=? c-username (cadar name))
               user-details)))
;;
;; memoize: transform a procedure into a version that caches its results.
;;
  (define (memoize fn)
    (let ((cache '()))
      (lambda args
        (apply values
               (or
               (cond
                 ((assoc args cache) => cdr)
                 (else #f))
                (call-with-values
                    (lambda () (apply fn args))
                  (lambda result
                    (set! cache (cons (cons args result) cache))
                    result)))))))
;;
;; Memoize the user-details procedure because it's an expensive call and
;; the information doesn't change often.
;;
  (define user-details (memoize unmemoized-user-details))
;;
;; user-exists? predicate for user existence is the same as user-details
;;
  (define user-exists? user-details)
;;
;; l-user-groups: a list of groups of which user is a member
;;
  (define sxg (sxpath "api/query/allusers/u/groups/g"))
  (define (l-user-groups user #!key wiki)
    (and-let* ((wiki (or wiki (default-wiki)))
               (details (user-details (canonical-username user) wiki: wiki)))
              (map cadr (sxg details))))
;;
;; user-group?: predicate for group membership
;;
  (define (user-group? user group #!key wiki)
    (and-let* ((glist (l-user-groups user wiki: wiki))
               (groups (if (pair? group) group (list group))))
              (let loop ((groups groups))
                (or (null? groups)
                    (and (member (->string (car groups)) glist)
                         (loop (cdr groups)))))))
;;
;; make-user-group-predicate: return a predicate for membership of a given group
;;
  (define (make-user-group-predicate group)
    (lambda (user #!key wiki)
      (user-group? user group wiki: wiki)))
;;
;; Some handy user group membership predicates.
;;
  (define user-accountcreator? (make-user-group-predicate 'accountcreator))
  (define user-abusefilter?    (make-user-group-predicate 'abusefilter))
  (define user-autoreviewer?   (make-user-group-predicate 'autoreviewer))
  (define user-boardvote?	(make-user-group-predicate 'boardvote))
  (define user-bot?		(make-user-group-predicate 'bot))
  (define user-bureaucrat?	(make-user-group-predicate 'bureaucrat))
  (define user-checkuser?	(make-user-group-predicate 'checkuser))
  (define user-confirmed?      (make-user-group-predicate 'confirmed))
  (define user-developer?	(make-user-group-predicate 'developer))
  (define user-founder?        (make-user-group-predicate 'founder))
  (define user-import?		(make-user-group-predicate 'import))
  (define user-ipblock-exempt? (make-user-group-predicate 'ipblock-exempt))
  (define user-oversight?	(make-user-group-predicate 'oversight))
  (define user-rollbacker?     (make-user-group-predicate 'rollbacker))
  (define user-steward?	(make-user-group-predicate 'steward))
  (define user-sysop?		(make-user-group-predicate 'sysop))
  (define user-transwiki?      (make-user-group-predicate 'transwiki)))