blob: ac50c7b6b10a2e832bbd8cd3120ae30d3b0cc8ab (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
;;;; -*- 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)
#.(setf *readtable* (copy-readtable))
#.(setf (readtable-case *readtable*) :invert)
(defun mulk.journal.xml-rpc::metaWeblog.newPost (blogid username password struct publish)
(declare (ignore blogid username publish))
(flet ((do-stuff ()
(let ((props (xml-rpc-struct-alist struct)))
(assert (cdr (assoc :DESCRIPTION props)))
(assert (cdr (assoc :TITLE props)))
(create-or-edit-post (cdr (assoc :DESCRIPTION props))
(cdr (assoc :TITLE props))))))
(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))
(setq postid (etypecase postid
(string (parse-integer postid))
(number postid)))
(flet ((do-stuff ()
(let ((props (xml-rpc-struct-alist struct)))
(assert (cdr (assoc :DESCRIPTION props)))
(assert (cdr (assoc :TITLE props)))
(create-or-edit-post (cdr (assoc :DESCRIPTION props))
(cdr (assoc :TITLE props))
:post-id postid))))
(cond ((string= password *xml-rpc-key*) (do-stuff))
(t (with-wsse-authentication () (do-stuff))))))
(defun convert-entry-to-rss-item (entry)
(with-slots (title date body categories last-modification id uuid)
entry
(xml-rpc-struct :CATEGORIES (map 'vector #'uuid-of categories)
:pubDate (xml-rpc-time date)
:GUID uuid
:POSTID (format nil "~D" id)
:DESCRIPTION (htmlise-entry entry)
:LINK (link-to :view :post-id id :absolute t)
:permaLink (link-to :view :post-id id :absolute t)
:COMMENTS (link-to :view :post-id id :absolute t)
:TITLE title)))
(defun mulk.journal.xml-rpc::metaWeblog.getPost (postid username password)
(declare (ignore username password))
(setq postid (etypecase postid
(string (parse-integer postid))
(number postid)))
(convert-entry-to-rss-item (find-entry postid)))
(defun mulk.journal.xml-rpc::metaWeblog.getCategories (blogid username password)
(declare (ignore blogid username password))
#())
(defun mulk.journal.xml-rpc::metaWeblog.getRecentPosts (blogid username password number-of-posts)
(declare (ignore blogid))
(loop for post-id from (max 0
(+ (- (or (find-largest-post-id) 0)
number-of-posts)
1))
to (or (find-largest-post-id) -1)
collect (mulk.journal.xml-rpc::metaWeblog.getPost post-id username password)))
(defun mulk.journal.xml-rpc::blogger.getUsersBlogs (appkey username password)
(declare (ignore appkey username password))
(list (xml-rpc-struct :BLOGID "0" :blogName "Kompottkins Weisheiten" :URL (link-to :view :absolute t))))
;; Not implemented: blogger.getUserInfo blogger.setTemplate blogger.getTemplate blogger.newPost blogger.editPost
(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)
(convert-entry-to-rss-item entry))))
(defun mulk.journal.xml-rpc::|pingback.ping| (source-uri target-uri)
#.(locally-enable-sql-reader-syntax)
(prog1
(let* ((last-uri-component (first (split-sequence #\/ target-uri :from-end t :count 1)))
(entry-id (ignore-errors (parse-integer last-uri-component)))
(entry (and entry-id (ignore-errors (find-entry entry-id)))))
(unless entry
(error (make-condition 'xml-rpc-fault :code #x20 :string "Couldn't find journal entry.")))
(with-transaction ()
(let ((existing-pingbacks
(select 'journal-pingback
:where [and [= [slot-value 'journal-pingback 'entry-id] entry-id]
[= [slot-value 'journal-pingback 'url] source-uri]]
:flatp t)))
(when existing-pingbacks
(error (make-condition 'xml-rpc-fault :code #x30 :string "The pingback you wanted to do was already registered.")))
(let ((pingback (make-instance 'journal-pingback
:id (make-journal-pingback-id)
:entry-id entry-id
:uuid (make-uuid)
:date (get-universal-time)
:url source-uri
:submitter-ip (http-getenv "REMOTE_ADDR")
:submitter-user-agent (http-getenv "HTTP_USER_AGENT")
:spamp nil)))
(update-records-from-instance pingback)
(update-records 'journal_pingback
:where [= [slot-value 'journal-pingback 'id] (id-of pingback)]
:av-pairs `((spam_p nil)))
(when (eq *site* :nfs.net)
(mail-pingback *notification-email* pingback entry))))))
#.(restore-sql-reader-syntax-state)))
|
