;; 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 provides miscellaneous procedures to do useful tasks such as
; getting a page's content and checking a user's status.
;
(module mw-user
  (export
   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)
;;
;; unmemoized-user-details: details of a user
;;
  (define sxname (sxpath "api/query/allusers/u/@name"))
  (define (unmemoized-user-details username #!rest z  #!key wiki)
    (mw:check-arguments 'user-details  z '(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 #!rest z #!key wiki)
    (mw:check-arguments 'l-user-groups z '(wiki))
    (let ((wiki (or wiki (default-wiki))))
      (and-let* ((details (user-details (canonical-username user) wiki: wiki)))
                (map cadr (sxg details)))))
;;
;; user-group?: predicate for group membership
;;
  (define (user-group? user group #!rest z #!key wiki)
    (mw:check-arguments 'user-group? z '(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))
 )