Gauche:Mailmanの制御

(Shiro:2005/08/10 02:13:57 PDT) 仕事で運用しているサイトで、「メンバーの登録情報を もとにMailmanでメーリングリストを運用したい」という要求が上がった。 ただ、Mailmanの走っているホストはサイトのホストとは別で、 Mailmanのコマンドラインインタフェースがたたけない。

本来こういうのは何らかのRPC技術で解決するのがまっとうなんだろうけど、 とりあえず動かさなくちゃならなかったんでwebインタフェースをたたくコードを でっちあげた。Mailmanの仕様が変わったらすぐ動かなくなるようなやっつけスクリプトなんで、 ライブラリ化する程のこともないが、何かの参考になるかもしれないので貼っておく。

(use rfc.http)
(use rfc.uri)
(use gauche.logger)

(define-class <mailman> ()
  ((server   :init-keyword :server)     ; listserver name
   (name     :init-keyword :name)       ; list name
   (password :init-keyword :password)   ; admin password
   (cookie   :init-value #f)))

(define-method mailman-login ((mailman <mailman>))
  (receive (status headers body)
      (http-post (ref mailman 'server)
                 #`"/admin.cgi/,(ref mailman 'name)"
                 #`"adminpw=,(ref mailman 'password);admlogin=Let me in...")
    (unless (equal? status "200")
      (log-format "mailman-login status: ~a" status)
      (log-format "mailman-login body: ~a" body))
    (and-let* ((p (assoc "set-cookie" headers))
               (rx (string->regexp #`",(ref mailman 'name)\\+admin=([^;]+)"))
               (m  (rx (cadr p))))
      (set! (ref mailman 'cookie) (m 1))
      #t)))

(define-method mailman-subscribe ((mailman <mailman>) . addresses)
  (let ((uri #`"/admin.cgi/,(ref mailman 'name)/members/add")
        (data `(""
                "--boundary"
                "Content-disposition: form-data; name=\"subscribe_or_invite\""
                ""
                "0"
                "--boundary"
                "Content-disposition: form-data; name=\"send_welcome_msg_to_this_batch\""
                ""
                "0"
                "--boundary"
                "Content-disposition: form-data; name=\"send_notifications_to_list_owner\""
                ""
                "1"
                "--boundary"
                "Content-disposition: form-data; name=\"subscribees\""
                ""
                ,@addresses
                ""
                "--boundary"
                "Content-disposition: form-data; name=\"invitation\""
                ""
                ""
                "--boundary"
                "Content-disposition: form-data; name=\"setmemberopts_btn\""
                ""
                "Submit Your Changes"
                "--boundary--"))
        (cookie #`"$Version=1;,(ref mailman 'name)+admin=,(ref mailman 'cookie);$Path=/"))
    (receive (status headers body)
        (http-post (ref mailman 'server) uri
                   (string-join data "\r\n" 'suffix)
                   :mime-version "1.0"
                   :content-type "multipart/form-data; boundary=boundary"
                   :cookie cookie)
      (cond ((equal? status "200")
             (log-format "mailman-subscribe OK: ~a" addresses)
             #t)
            (else
             (log-format "mailman-subscribe status: ~a" status)
             (log-format "mailman-subscribe body: ~a" body)
             #f)))))
                 
(define-method mailman-unsubscribe ((mailman <mailman>) . addresses)
  (let ((uri #`"/admin.cgi/,(ref mailman 'name)/members/remove")
        (data `(""
                "--boundary"
                "Content-disposition: form-data; name=\"send_unsub_ack_to_this_batch\""
                ""
                "0"
                "--boundary"
                "Content-disposition: form-data; name=\"send_unsub_notifications_to_list_owner\""
                ""
                "0"
                "--boundary"
                "Content-disposition: form-data; name=\"unsubscribees\""
                ""
                ,@addresses
                ""
                "--boundary"
                "Content-disposition: form-data; name=\"setmemberopts_btn\""
                ""
                "Submit Your Changes"
                "--boundary--"))
        (cookie #`"$Version=1;,(ref mailman 'name)+admin=,(ref mailman 'cookie);$Path=/"))
    (receive (status headers body)
        (http-post (ref mailman 'server) uri
                   (string-join data "\r\n" 'suffix)
                   :mime-version "1.0"
                   :content-type "multipart/form-data; boundary=boundary"
                   :cookie cookie)
      (cond ((equal? status "200")
             (log-format "mailman-unsubscribe OK: ~a" addresses)
             #t)
            (else
             (log-format "mailman-unsubscribe status: ~a" status)
             (log-format "mailman-unsubscribe body: ~a" body)
             #f)))))