make list-head-nice more idiomatic; use it in movabletype
[tekuti:acf-tekuti.git] / tekuti / movabletype.scm
1 ;; Tekuti
2 ;; Copyright (C) 2011 Aleix Conchillo Flaque <aconchillo at gmail dot com>
3
4 ;; This program is free software; you can redistribute it and/or
5 ;; modify it under the terms of the GNU General Public License as
6 ;; published by the Free Software Foundation; either version 3 of
7 ;; the License, or (at your option) any later version.
8 ;;
9 ;; This program is distributed in the hope that it will be useful,
10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12 ;; GNU General Public License for more details.
13 ;;
14 ;; You should have received a copy of the GNU General Public License
15 ;; along with this program; if not, contact:
16 ;;
17 ;; Free Software Foundation           Voice:  +1-617-542-5942
18 ;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
19 ;; Boston, MA  02111-1307,  USA       gnu@gnu.org
20
21 ;;; Commentary:
22 ;;
23 ;; Tekuti Movable Type support.
24 ;;
25 ;;; Code:
26
27 (define-module (tekuti movabletype)
28   #:use-module (srfi srfi-1)
29   #:use-module (srfi srfi-19)
30   #:use-module (web uri)
31   #:use-module (web response)
32   #:use-module (tekuti config)
33   #:use-module (tekuti page-helpers)
34   #:use-module (tekuti post)
35   #:use-module (tekuti url)
36   #:use-module (tekuti util)
37   #:use-module (tekuti xmlrpc)
38   #:export (movabletype-handler))
39
40 (define (mt-post-data->post-data data)
41   `(("title" . ,(assq-ref data 'title))
42     ("body" . ,(assq-ref data 'description))
43     ("tags" . ,(or (assq-ref data 'mt_tags) (assq-ref data 'mt_keywords)))
44     ("status" . "publish")
45     ("comments" . ,(assq-ref data 'mt_allow_comments))))
46
47 (define (post->mt-post-data post)
48   (let ((link (uri->string (ensure-public-uri (post-url post)))))
49     `((postid . ,(sxmlrpc-string (post-key post)))
50       (dateCreated . ,(sxmlrpc-date
51                        (timestamp->date (post-timestamp post))))
52       (title . ,(sxmlrpc-string (post-title post)))
53       (description . ,(sxmlrpc-string (post-raw-content post)))
54       (categories . ,(sxmlrpc-array '()))
55       (publish . ,(sxmlrpc-boolean (post-published? post)))
56       (userid . ,(sxmlrpc-string (post-author post)))
57       (link . ,(sxmlrpc-string link))
58       (permaLink . ,(sxmlrpc-string link))
59       (mt_allow_comments . ,(sxmlrpc-integer (if (post-comments-open? post) 1 0)))
60       (mt_keywords . ,(sxmlrpc-string (list-intersperse (post-tags post) ", ")))
61       (mt_tags . ,(sxmlrpc-string (list-intersperse (post-tags post) ", ")))
62       (mt_excerpt . ,(sxmlrpc-string ""))
63       (mt_text_more . ,(sxmlrpc-string ""))
64       (mt_allow_pings . ,(sxmlrpc-integer 0))
65       (mt_convert_breaks . ,(sxmlrpc-string "")))))
66
67 (define (make-new-post-sxmlrpc data)
68   (let ((date (or (assq-ref data 'dateCreated)
69                   (current-date))))
70     (make-new-post (acons "date" (date->rfc822-date date)
71                           (mt-post-data->post-data data)))))
72
73 (define (modify-post-sxmlrpc index postid data)
74   (let* ((post (post-from-key index postid))
75          (date-str (timestamp->rfc822-date (post-timestamp post))))
76     (modify-post postid (acons "date" date-str
77                                (mt-post-data->post-data data)))))
78
79 ;; Response utilities
80
81 (define (xmlrpc-respond params response-func)
82   (values (build-response
83            #:headers '((content-type . (text/xml))))
84           (lambda (port)
85             (display "<?xml version='1.0'?>\n" port)
86             (response-func params port))))
87
88 (define (xmlrpc-respond-ok params)
89   (xmlrpc-respond params sxmlrpc-response->xml))
90
91 (define (xmlrpc-respond-fault code message)
92   (xmlrpc-respond (sxmlrpc-fault code message) sxmlrpc-fault->xml))
93
94 (define (xmlrpc-respond-fault-auth)
95   (xmlrpc-respond-fault 401 "Wrong user name or password"))
96
97 ;; Authentication
98
99 (define (mt-authenticated? user password)
100   (and (equal? user *admin-user*)
101        (equal? password *admin-pass*)))
102
103 (define (mt-with-authentication user password thunk)
104   (if (mt-authenticated? user password)
105       (thunk)
106       (xmlrpc-respond-fault-auth)))
107
108 ;; MetaWebLog
109
110 (define (mw-new-post params index)
111   (let ((user (second params))
112         (password (third params))
113         (data (fourth params)))
114     (mt-with-authentication
115      user password
116      (lambda ()
117        (xmlrpc-respond-ok (list (post-key (make-new-post-sxmlrpc data))))))))
118
119 (define (mw-get-post params index)
120   (let ((postid (first params))
121         (user (second params))
122         (password (third params)))
123     (mt-with-authentication
124      user password
125      (lambda ()
126        (let ((post (post-from-key index postid)))
127          (xmlrpc-respond-ok (sxmlrpc-struct (post->mt-post-data post))))))))
128
129 (define (mw-edit-post params index)
130   (let ((postid (first params))
131         (user (second params))
132         (password (third params))
133         (new-data (fourth params)))
134     (mt-with-authentication
135      user password
136      (lambda ()
137        (modify-post-sxmlrpc index postid new-data)
138        (xmlrpc-respond-ok (sxmlrpc-boolean #t))))))
139
140 (define (mw-get-posts params index)
141   (let ((user (second params))
142         (password (third params))
143         (count (fourth params)))
144     (mt-with-authentication
145      user password
146      (lambda ()
147        (let ((posts (assq-ref index 'posts)))
148          (xmlrpc-respond-ok
149           (sxmlrpc-array (map (lambda (p) (sxmlrpc-struct (post->mt-post-data p)))
150                               (list-head-nice posts count)))))))))
151
152 ;; Movable Type
153
154 (define (mt-supported-methods params index)
155   (xmlrpc-respond-ok (sxmlrpc-array (map sxmlrpc-string
156                                          '("metaWeblog.newPost"
157                                            "metaWeblog.getPost"
158                                            "metaWeblog.editPost"
159                                            "metaWeblog.getRecentPosts"
160                                            "metaWeblog.getCategories"
161                                            "mt.setPostCategories"
162                                            "mt.getPostCategories"
163                                            "mt.getCategoryList"
164                                            "blogger.getUsersBlogs"
165                                            "blogger.deletePost")))))
166
167 (define (mt-set-post-categories params index)
168   (let ((postid (first params))
169         (user (second params))
170         (password (third params))
171         (categories (fourth params)))
172     (mt-with-authentication
173      user password
174      (lambda ()
175        (xmlrpc-respond-ok (sxmlrpc-boolean #t))))))
176
177 (define (mt-get-empty-categories params index)
178   (let ((user (second params))
179         (password (third params)))
180     (mt-with-authentication
181      user password
182      (lambda ()
183        (xmlrpc-respond-ok (sxmlrpc-array '()))))))
184
185 ;; Blogger
186
187 (define (bg-get-users-blogs params index)
188   (let ((user (second params))
189         (password (third params)))
190     (mt-with-authentication
191      user password
192      (lambda ()
193        (let ((link (uri->string (ensure-public-uri ""))))
194          (xmlrpc-respond-ok
195           (sxmlrpc-array `(,(sxmlrpc-struct `(((url . link)
196                                                (blogid . "tekuti")
197                                                (blogName . ,*title*))))))))))))
198
199 (define (bg-delete-post params index)
200   (let ((postid (second params))
201         (user (third params))
202         (password (fourth params)))
203     (mt-with-authentication
204      user password
205      (lambda ()
206        (delete-post postid)
207        (xmlrpc-respond-ok (sxmlrpc-boolean #t))))))
208
209 ;; Main handler
210
211 (define (movabletype-handler request body index)
212   (let* ((xmlrpc (xml->sxmlrpc-request body))
213          (method (sxmlrpc-request-method xmlrpc))
214          (params (sxmlrpc-request-params xmlrpc)))
215     (case method
216       ((metaWeblog.newPost) (mw-new-post params index))
217       ((metaWeblog.getPost) (mw-get-post params index))
218       ((metaWeblog.editPost) (mw-edit-post params index))
219       ((metaWeblog.getRecentPosts) (mw-get-posts params index))
220       ((metaWeblog.getCategories) (mt-get-empty-categories params index))
221       ((mt.supportedMethods) (mt-supported-methods params index))
222       ((mt.setPostCategories) (mt-set-post-categories params index))
223       ((mt.getPostCategories) (mt-get-empty-categories params index))
224       ((mt.getCategoryList) (mt-get-empty-categories params index))
225       ((blogger.getUsersBlogs) (bg-get-users-blogs params index))
226       ((blogger.deletePost) (bg-delete-post params index))
227       (else (xmlrpc-respond-fault 501 "Operation not implemented")))))