From 1eabb03185a08f4088d8fefba9c4137ea90c3e33 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Fri, 30 Oct 2009 21:29:00 +0100
Subject: Add missing MetaWeblog implementation files.
Ignore-this: a780097e9cdf0842a1251b950a9ff80d
darcs-hash:06343f6ad20b076298cd9df5477dbb7561a36530
---
mulk-journal.asd | 3 +-
xml-rpc-functions.lisp | 80 ++++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 82 insertions(+), 1 deletion(-)
create mode 100644 xml-rpc-functions.lisp
diff --git a/mulk-journal.asd b/mulk-journal.asd
index 50bbaf0..92eee34 100644
--- a/mulk-journal.asd
+++ b/mulk-journal.asd
@@ -37,5 +37,6 @@
(:file "utils")
(:file "journal-content")
(:file "journal")
- (:file "main"))
+ (:file "main")
+ (:file "xml-rpc-functions"))
:serial t)
diff --git a/xml-rpc-functions.lisp b/xml-rpc-functions.lisp
new file mode 100644
index 0000000..0bba5c6
--- /dev/null
+++ b/xml-rpc-functions.lisp
@@ -0,0 +1,80 @@
+;;;; -*- coding: utf-8; mode: lisp -*-
+;;;; Copyright 2009, Matthias Andreas Benkard.
+
+;;;------------------------------------------------------------------------
+;;; This file is part of The Mulkblog Project.
+;;;
+;;; The Mulkblog Project is free software. You can redistribute it and/or
+;;; modify it under the terms of the Affero General Public License as
+;;; published by Affero, Inc.; either version 1 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; The Mulkblog Project is distributed in the hope that it will be
+;;; useful, but WITHOUT ANY WARRANTY; without even the implied warranty
+;;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the Affero General Public
+;;; License in the COPYING file that comes with The Mulkblog Project; if
+;;; not, write to Affero, Inc., 510 Third Street, Suite 225, San
+;;; Francisco, CA 94107 USA.
+;;;------------------------------------------------------------------------
+
+(in-package #:mulk.journal)
+
+(defun mulk.journal.xml-rpc::|metaWeblog.newPost| (blogid username password struct publish)
+ (declare (ignore blogid username publish))
+ (flet ((do-stuff ()
+ (with-slots (categories pub-date guid description link comments title)
+ struct
+ (create-or-edit-post description title))))
+ (cond ((string= password *xml-rpc-key*) (do-stuff))
+ (t (with-wsse-authentication () (do-stuff))))))
+
+
+(defun mulk.journal.xml-rpc::|metaWeblog.editPost| (postid username password struct publish)
+ (declare (ignore username publish))
+ (flet ((do-stuff ()
+ (with-slots (categories pub-date guid description link comments title)
+ struct
+ (create-or-edit-post description title :post-id postid))))
+ (cond ((string= password *xml-rpc-key*) (do-stuff))
+ (t (with-wsse-authentication () (do-stuff))))))
+
+
+(defun mulk.journal.xml-rpc::|metaWeblog.getPost| (postid username password)
+ (declare (ignore username password))
+ (with-slots (title date body categories last-modification id uuid)
+ (find-entry postid)
+ (xml-rpc-struct :categories (mapcar #'uuid-of categories)
+ :pub-date (xml-rpc-time date)
+ :guid uuid
+ :description body
+ :link (link-to :view :post-id postid :absolute t)
+ :comments (link-to :view :post-id postid :absolute t)
+ :title title)))
+
+
+(defun create-or-edit-post (body title &key entry-type post-id)
+ (with-transaction ()
+ (let* ((entry (if post-id
+ (find-entry post-id)
+ (make-instance 'journal-entry
+ :id (make-journal-entry-id)
+ :uuid (make-uuid)
+ :date (get-universal-time)
+ :last-modification nil
+ :categories ()
+ :comments ()))))
+ (unless post-id
+ (setf (last-modification-of entry)
+ (get-universal-time)))
+ (setf (body-of entry) (etypecase body
+ (null "")
+ (cons (xmls:toxml body :indent t))
+ (string body)))
+ (setf (title-of entry) (or title ""))
+ (setf (entry-type-of entry) (or entry-type "html"))
+ (update-records-from-instance entry)
+ ;; Update static files.
+ (update-journal))))
\ No newline at end of file
--
cgit v1.2.3