/[stamp]/stamp/message-composing.lisp
ViewVC logotype

Contents of /stamp/message-composing.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Wed Dec 5 12:18:52 2007 UTC (6 years, 4 months ago) by rstrandh
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +2 -0 lines
Added declaim with a debug level of 3 for better source tracking.
1 ;;; message-composing
2
3 (in-package :stamp-gui)
4
5 (declaim (optimize (debug 3)))
6
7 (defparameter *outbox* '())
8 (defparameter *mailboxes* '())
9 (defparameter *address* '())
10
11 (defparameter *climacs-frame* nil)
12 (defparameter *climacs-startup-hook* nil)
13
14 (defmethod clim:adopt-frame :after (frame-manager (frame climacs-gui:climacs))
15 (when *climacs-startup-hook*
16 (funcall *climacs-startup-hook*)))
17
18 (defun compose-message (&key (to "") (subject "") body)
19 (let ((content-filename (make-temporary-filename)))
20 (with-open-file (out content-filename :direction :output)
21 (princ (make-message-file-contents :to to
22 :subject subject
23 :body body)
24 out))
25 (let ((filename (make-temporary-filename)))
26 (let ((*climacs-startup-hook*
27 (lambda ()
28 (clim:layout-frame *climacs-frame* 800 600)
29 (clim:execute-frame-command
30 *climacs-frame*
31 `(climacs-core::find-file ,filename))
32 (clim:execute-frame-command
33 *climacs-frame*
34 `(climacs-commands::com-insert-file ,content-filename))
35 (delete-file content-filename)))
36 (*climacs-frame*
37 (clim:make-application-frame 'climacs-gui:climacs)))
38 (clim:run-frame-top-level *climacs-frame*))
39 (let ((parsed-data (ignore-errors (parse-message-file filename))))
40 (when (probe-file filename)
41 (delete-file filename))
42 (values (first parsed-data)
43 (second parsed-data)
44 (third parsed-data))))))
45
46
47
48 ;;; This should be a defconstant, but it is not very
49 ;;; practical during development, because of the number
50 ;;; of times the file gets reloaded. -- RS 2007-01-04
51 (defparameter +boundary+ "---- text follows this line ----")
52
53 (defun make-temporary-filename ()
54 (let ((base (format nil "/tmp/stamp-~A" (get-universal-time))))
55 (loop for i from 0
56 as path = (format nil "~A-~A" base i)
57 while (probe-file path)
58 finally (return path))))
59
60 (defun make-message-file-contents (&key (to "") (subject "") body)
61 (with-output-to-string (out)
62 (format out "To: ~A~%" to)
63 (format out "Subject: ~A~%" subject)
64 (format out "~A~%" +boundary+)
65 (when body
66 (princ body out))))
67
68 (defun parse-message-file (filename)
69 (let* ((string (with-open-file (stream filename)
70 (read-stream-as-string stream)))
71 (boundary-position (search +boundary+ string)))
72 (when boundary-position
73 (let* ((headers (parse-headers string 0 boundary-position))
74 (to (cdr (assoc :to headers)))
75 (body (string-trim '(#\space #\return #\linefeed)
76 (subseq string (+ boundary-position
77 (length +boundary+))))))
78 (when to
79 (let ((message
80 (mel:make-message :subject (cdr (assoc :subject headers))
81 :from *address*
82 :to (cdr (assoc :to headers))
83 :body body)))
84 (setf (mel:header-fields message) headers)
85 (list message headers body)))))))
86
87 (defun parse-headers (string start end)
88 (let ((lines (mapcar (lambda (line)
89 (string-trim '(#\space #\return) line))
90 (split-sequence:split-sequence #\newline string
91 :start start
92 :end end))))
93 (loop for line in lines
94 as index = (position #\: line)
95 unless (null index)
96 collect (cons (intern (string-upcase (subseq line 0 index)) :keyword)
97 (string-trim '(#\space) (subseq line (1+ index)))))))
98
99 (defun print-headers (headers stream)
100 (loop for header in headers
101 as name = (symbol-name (car header))
102 do (format stream "~A: ~A~%" (capitalize-words name) (cdr header))))
103
104 (defun quote-message-text (text author)
105 (let ((lines (mapcar (lambda (line)
106 (string-trim '(#\space #\return) line))
107 (split-sequence:split-sequence #\newline text))))
108 (with-output-to-string (out)
109 (when author
110 (format out "~A wrote:~%" author))
111 (loop for line in lines
112 do (format out "> ~A~%" line)))))
113
114 (defun send-message (message headers body)
115 (let ((stream (mel:open-message-storing-stream *outbox* message)))
116 (unwind-protect
117 (progn
118 (print-headers headers stream)
119 (format stream body))
120 (close stream))))
121

  ViewVC Help
Powered by ViewVC 1.1.5