From e4b27cf22677f46c2f9f9e61496236246c1f2efd Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Fri, 30 Oct 2009 20:06:53 +0100
Subject: Implement the MetaWeblog API.

Ignore-this: 8157da40368760fdfdfe527b33134f4

darcs-hash:3ba0c89c45f5b5bcd9000e71ea700b3df00892b5
---
 defpackage.lisp  | 10 ++++++++--
 globals.lisp     |  1 +
 main.lisp        | 31 +++++++++++++++++++++++--------
 mulk-journal.asd |  2 +-
 4 files changed, 33 insertions(+), 11 deletions(-)

diff --git a/defpackage.lisp b/defpackage.lisp
index 3911d1b..9f4ffd9 100644
--- a/defpackage.lisp
+++ b/defpackage.lisp
@@ -1,5 +1,5 @@
 ;;;; -*- coding: utf-8; mode: lisp -*-
-;;;; Copyright 2007, Matthias Andreas Benkard.
+;;;; Copyright 2007-2009, Matthias Andreas Benkard.
 
 ;;;------------------------------------------------------------------------
 ;;; This file is part of The Mulkblog Project.
@@ -23,5 +23,11 @@
 (defpackage #:mulk.journal
   (:nicknames #:journal)
   (:use #:cl #:fad #:iterate #:markdown #:yaclml #:http #:alexandria
-        #:xml-emitter #:split-sequence #:clsql #:drakma)
+        #:xml-emitter #:split-sequence #:clsql #:drakma #:s-xml-rpc)
   (:shadow #:copy-file #:copy-stream #:format-date))
+
+(defpackage #:mulk.journal.xml-rpc
+  (:nicknames #:journal-xml-rpc)
+  ;; Do not :USE anything here, not even #:COMMON-LISP!
+  (:use)
+  (:import-from #:s-xml-rpc-exports #:system.getCapabilities #:system.listMethods #:system.methodHelp #:system.methodSignature #:system.multicall))
diff --git a/globals.lisp b/globals.lisp
index e1b9567..b796b0a 100644
--- a/globals.lisp
+++ b/globals.lisp
@@ -81,6 +81,7 @@
 (defparameter *if-modified-since* nil)
 (defparameter *wsse* nil)
 (defparameter *wsse-key* nil)
+(defparameter *xml-rpc-key* nil)
 
 (defparameter *mode* :http  ;either :HTTP or :FILE
   "Whether we are serving stuff dynamically over HTTP or storing it into
diff --git a/main.lisp b/main.lisp
index df03ffe..9b290a4 100644
--- a/main.lisp
+++ b/main.lisp
@@ -77,9 +77,13 @@
                                                    "wordpress-api-key.key"
                                                    *data-dir*))
                               (read-line file)))
-         (*wsse-key*   (with-open-file (file (merge-pathnames
-                                              "wsse.key"
-                                              *data-dir*))
+         (*wsse-key*        (with-open-file (file (merge-pathnames
+                                                   "wsse.key"
+                                                   *data-dir*))
+                              (read-line file)))
+         (*xml-rpc-key*     (with-open-file (file (merge-pathnames
+                                                   "xml-rpc.key"
+                                                   *data-dir*))
                               (read-line file)))
          (database-file     (merge-pathnames #p"journal.sqlite3" *data-dir*))
          (sqlite-library    (merge-pathnames #p"libsqlite3.so"
@@ -299,10 +303,7 @@
                   (flet ((tag-equal (tag1 tag2)
                            (equal (if (consp tag1) (car tag1) tag1)
                                   (if (consp tag2) (car tag2) tag2))))
-                    (let* ((post-data (with-output-to-string (out)
-                                        (loop for line = (read-line *standard-input* nil nil nil)
-                                              while line
-                                              do (write-line line out))))
+                    (let* ((post-data (slurp-post-data))
                            (xml (xmls:parse post-data))
                            (entry-elements (cddr xml))
                            (content-element (find "content" entry-elements :key 'car :test #'tag-equal))
@@ -327,10 +328,24 @@
     (:view-atom-feed (show-atom-feed))
     (:view-comment-feed (show-comment-feed))
     (:view-debugging-page (show-debugging-page))
-    (otherwise       (show-web-journal)))
+    (:xml-rpc (when (eq *method* :post)
+                (let ((xml-data (slurp-post-data)))
+                  (http-add-header "Content-Language" "de")
+                  (http-send-headers "text/xml; charset=UTF-8")
+                  (write (let ((*xml-rpc-package*
+                                (find-package '#:mulk.journal.xml-rpc)))
+                           (s-xml-rpc::handle-xml-rpc-call xml-data 0))
+                         :stream *standard-output*))))
+    (otherwise (show-web-journal)))
   #.(restore-sql-reader-syntax-state))
 
 
+(defun slurp-post-data ()
+  (with-output-to-string (out)
+    (loop for line = (read-line *standard-input* nil nil nil)
+          while line
+          do (write-line line out))))
+
 #+clisp
 (defun journal-main (&key admin-mode)
   (let ((encoding (ext:make-encoding :charset charset:utf-8)))
diff --git a/mulk-journal.asd b/mulk-journal.asd
index 9dc15df..50bbaf0 100644
--- a/mulk-journal.asd
+++ b/mulk-journal.asd
@@ -26,7 +26,7 @@
   :depends-on  (#:cl-ppcre #:cl-fad #:iterate #:cl-markdown #:parenscript
                 #:yaclml #:lisp-cgi-utils #:alexandria #:xml-emitter
                 #:split-sequence #:clsql #:clsql-uffi #:clsql-sqlite3
-                #:drakma #:cybertiggyr-time)
+                #:drakma #:cybertiggyr-time #:s-xml-rpc)
   :components  ((:module "cybertiggyr-time"
                          :components ((:file "time")))
                 (:module "xmls" :components ((:file "xmls")))
-- 
cgit v1.2.3