about summary refs log tree commit diff
path: root/third_party/lisp/mime4cl/mime.lisp
blob: b3c10d79764af8b3640da35d11dffdc4c3a89cd7 (plain) (blame)
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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
;;;  mime4cl.lisp --- MIME primitives for Common Lisp

;;;  Copyright (C) 2005-2008, 2010 by Walter C. Pelissero
;;;  Copyright (C) 2021-2023 by the TVL Authors

;;;  Author: Walter C. Pelissero <walter@pelissero.de>
;;;  Project: mime4cl

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
;;; as published by the Free Software Foundation; either version 2.1
;;; of the License, or (at your option) any later version.
;;; This library 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 GNU
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;; 02111-1307 USA

(in-package :mime4cl)

(defclass mime-part ()
  ((subtype
    :type (or string null)
    :initarg :subtype
    :accessor mime-subtype
    ;; some mime types don't require a subtype
    :initform nil)
   (type-parameters
    :type list
    :initarg :type-parameters
    :initform '()
    :accessor mime-type-parameters)
   (version
    :type (or string null)
    :initarg :mime-version
    :initform "1.0"
    :accessor mime-version)
   (id
    :initform nil
    :initarg :id
    :reader mime-id)
   (description
    :initform nil
    :initarg :description
    :accessor mime-description)
   (encoding
    :initform :7bit
    :initarg :encoding
    :reader mime-encoding
    :documentation
    "It's supposed to be either:
  :7BIT, :8BIT, :BINARY, :QUOTED-PRINTABLE, :BASE64, a
  X-token or an ietf-token (whatever that means).")
   (disposition
    :type (or string null)
    :initarg :disposition
    :initform nil
    :accessor mime-disposition)
   (disposition-parameters
    :type list
    :initarg :disposition-parameters
    :initform '()
    :accessor mime-disposition-parameters))
  (:documentation
   "Abstract base class for all types of MIME parts."))

(defclass mime-bodily-part (mime-part)
  ((body
    :initarg :body
    :accessor mime-body))
  (:documentation
   "Abstract base class for MIME parts with a body."))

(defclass mime-unknown-part (mime-bodily-part)
  ((type
    :initarg :type
    :reader mime-type
    :documentation
    "The original type string from the MIME header."))
  (:documentation
   "MIME part unknown to this library.  Accepted but not handled."))

(defclass mime-text (mime-bodily-part) ())

;; This turns out to be handy when making methods specialised
;; non-textual attachments.
(defclass mime-binary (mime-bodily-part) ())

(defclass mime-image (mime-binary) ())

(defclass mime-audio (mime-binary) ())

(defclass mime-video (mime-binary) ())

(defclass mime-application (mime-binary) ())

(defclass mime-multipart (mime-part)
  ((parts :initarg :parts
          :accessor mime-parts)))

(defclass mime-message (mime-part)
  ((headers :initarg :headers
            :initform '()
            :type list
            :accessor mime-message-headers)
   (real-message :initarg :body
                 :accessor mime-body)))

(defun mime-part-p (object)
  (typep object 'mime-part))

(defmethod initialize-instance ((part mime-multipart) &key &allow-other-keys)
  (call-next-method)
  ;; The initialization argument of the PARTS slot of a mime-multipart
  ;; is expected to be a list of mime-parts.  Thus, we implicitly
  ;; create the mime parts using the arguments found in this list.
  (with-slots (parts) part
    (when (slot-boundp part 'parts)
      (setf parts
            (mapcar #'(lambda (subpart)
                        (if (mime-part-p subpart)
                            subpart
                            (apply #'make-instance subpart)))
                    parts)))))

(defmethod initialize-instance ((part mime-message) &key &allow-other-keys)
  (call-next-method)
  ;; Allow a list of mime parts to be specified as body of a
  ;; mime-message.  In that case we implicitly create a mime-multipart
  ;; and assign to the body slot.
  (with-slots (real-message) part
    (when (and (slot-boundp part 'real-message)
               (consp real-message))
      (setf real-message
            (make-instance 'mime-multipart :parts real-message)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun alist= (alist1 alist2 &key (test #'eql))
  (null
   (set-difference alist1 alist2
                   :test #'(lambda (x y)
                             (and (funcall test (car x) (car y))
                                  (funcall test (cdr x) (cdr y)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric mime= (mime1 mime2)
  (:documentation
   "Return true if MIME1 and MIME2 have equivalent structure and identical bodies (as for EQ)."))

(defmethod mime= ((part1 mime-part) (part2 mime-part))
  (macrolet ((null-or (compare x y)
               `(or (and (not ,x)
                         (not ,y))
                    (and ,x ,y
                         (,compare ,x ,y))))
             (cmp-slot (compare reader)
               `(null-or ,compare (,reader part1) (,reader part2))))
    (and (eq (class-of part1) (class-of part2))
         (cmp-slot string-equal mime-subtype)
         (alist= (mime-type-parameters part1)
                 (mime-type-parameters part2)
                 :test #'string-equal)
         (cmp-slot string= mime-id)
         (cmp-slot string= mime-description)
         (cmp-slot eq mime-encoding)
         (cmp-slot equal mime-disposition)
         (alist= (mime-disposition-parameters part1)
                 (mime-disposition-parameters part2)
                 :test #'string-equal))))

(defmethod mime= ((part1 mime-multipart) (part2 mime-multipart))
  (and (call-next-method)
       (every #'mime= (mime-parts part1) (mime-parts part2))))

(defmethod mime= ((part1 mime-message) (part2 mime-message))
  (and (call-next-method)
       (alist= (mime-message-headers part1) (mime-message-headers part2)
               :test #'string=)
       (mime= (mime-body part1) (mime-body part2))))

(defun mime-body-stream (mime-part)
  (make-input-adapter (mime-body mime-part)))

(defun mime-body-length (mime-part)
  (let ((body (mime-body mime-part)))
    ;; here the stream type is missing on purpose, because we may not
    ;; be able to size the length of a stream
    (etypecase body
      (string
       (length body))
      (vector
       (length body))
      (pathname
       (file-size body))
      (file-portion
       (with-open-stream (in (open-decoded-file-portion body))
         (loop
            for byte = (read-byte in nil)
            while byte
            count byte))))))

(defmacro with-input-from-mime-body-stream ((stream part) &body forms)
  `(with-open-stream (,stream (mime-body-stream ,part))
     ,@forms))

(defmethod mime= ((part1 mime-bodily-part) (part2 mime-bodily-part))
  (and (call-next-method)
       (with-input-from-mime-body-stream (in1 part1)
         (with-input-from-mime-body-stream (in2 part2)
           (loop
              for b1 = (read-byte in1 nil)
              for b2 = (read-byte in2 nil)
              always (eq b1 b2)
              while (and b1 b2))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric get-mime-type-parameter (part name)
  (:documentation
   "Return the MIME type parameter associated to NAME of PART."))

(defgeneric (setf get-mime-type-parameter) (value part name)
  (:documentation
   "Set the MIME type parameter associated to NAME of PART."))

(defmethod get-mime-type-parameter ((part mime-part) name)
  (cdr (assoc name (mime-type-parameters part) :test #'string-equal)))

(defmethod (setf get-mime-type-parameter) (value part name)
  (aif (assoc name (mime-type-parameters part) :test #'string-equal)
       (setf (cdr it) value)
       (push (cons name value)
             (mime-type-parameters part)))
  value)

(defgeneric get-mime-disposition-parameter (part name)
  (:documentation
   "Return the MIME disposition parameter associated to NAME of PART."))

(defmethod get-mime-disposition-parameter ((part mime-part) name)
  (cdr (assoc name (mime-disposition-parameters part) :test #'string-equal)))

(defmethod (setf get-mime-disposition-parameter) (value part name)
  (aif (assoc name (mime-disposition-parameters part) :test #'string-equal)
       (setf (cdr it) value)
       (push (cons name value)
             (mime-disposition-parameters part))))

(defmethod mime-part-file-name ((part mime-part))
  "Return the filename associated to mime PART or NIL if the mime
part doesn't have a file name."
  (or (get-mime-disposition-parameter part :filename)
      (get-mime-type-parameter part :name)))

(defmethod (setf mime-part-file-name) (value (part mime-part))
  "Set the filename associated to mime PART."
  (setf (get-mime-disposition-parameter part :filename) value
        (get-mime-type-parameter part :name) value))

(defun mime-text-charset (part)
  (get-mime-type-parameter part :charset))

(defun split-header-parts (string)
  "Split parts of a MIME headers.  These are divided by
semi-colons not within strings or comments."
  (labels ((skip-comment (pos)
             (loop
                while (< pos (length string))
                do (case (elt string pos)
                     (#\( (setf pos (skip-comment (1+ pos))))
                     (#\\ (incf pos 2))
                     (#\) (return (1+ pos)))
                     (otherwise (incf pos)))
                finally (return pos)))
           (skip-string (pos)
             (loop
                while (< pos (length string))
                do (case (elt string pos)
                     (#\\ (incf pos 2))
                     (#\" (return (1+ pos)))
                     (otherwise (incf pos)))
                finally (return pos))))
    (loop
       with start = 0 and i = 0 and parts = '()
       while (< i (length string))
       do (case (elt string i)
            (#\; (push (subseq string start i) parts)
                 (setf start (incf i)))
            (#\" (setf i (skip-string i)))
            (#\( (setf i (skip-comment (1+ i))))
            (otherwise (incf i)))
       finally (return (mapcar #'string-trim-whitespace (nreverse (cons (subseq string start) parts)))))))

(defun parse-parameter (string)
  "Given a string like \"foo=bar\" return a pair (\"foo\" .
\"bar\").  Return NIL if string is not parsable."
  ;; TODO(sterni): when-let
  (let ((equal-position (position #\= string)))
    (when equal-position
      (let ((key (subseq string  0 equal-position)))
        (if (= equal-position (1- (length string)))
            (cons key "")
            (let ((value (string-trim-whitespace (subseq string (1+ equal-position)))))
              (cons key
                    (if (and (> (length value) 1)
                             (char= #\" (elt value 0)))
                        ;; the syntax of a RFC822 string is more or
                        ;; less the same as the Lisp one: use the Lisp
                        ;; reader
                        (or (ignore-errors (read-from-string value))
                            (subseq value 1))
                        (let ((end (or (position-if #'whitespace-p value)
                                       (length value))))
                          (subseq value 0 end))))))))))

(defun parse-content-type (string)
  "Parse string as a Content-Type MIME header and return a list
of three elements.  The first is the type, the second is the
subtype and the third is an alist of parameters and their values.
Example: (\"text\" \"plain\" ((\"charset\" . \"us-ascii\")...))."
  (let* ((parts (split-header-parts string))
         (content-type-string (car parts))
         (slash (position #\/ content-type-string)))
    ;; You'd be amazed to know how many MUA can't produce an RFC
    ;; compliant message.
    (when slash
      (let ((type (subseq content-type-string 0 slash))
            (subtype (subseq content-type-string (1+ slash))))
        (list type subtype (remove nil (mapcar #'parse-parameter (cdr parts))))))))

(defun parse-content-disposition (string)
  "Parse string as a Content-Disposition MIME header and return a
list.  The first element is the layout, the other elements are
the optional parameters alist.
Example: (\"inline\" (\"filename\" . \"doggy.jpg\"))."
  (let ((parts (split-header-parts string)))
    (cons (car parts) (mapcan #'(lambda (parameter-string)
                                  (awhen (parse-parameter parameter-string)
                                    (list it)))
                              (cdr parts)))))

(defun parse-RFC822-header (string)
  "Parse STRING which should be a valid RFC822 message header and
return two values: a string of the header name and a string of
the header value."
  (let ((colon (position #\: string)))
    (when colon
      (values (string-trim-whitespace (subseq string 0 colon))
              (string-trim-whitespace (subseq string (1+ colon)))))))


(defvar *default-type* '("text" "plain" (("charset" . "us-ascii")))
  "Internal special variable that contains the default MIME type at
any given time of the parsing phase.  There are MIME container parts
that may change this.")

(defvar *mime-types*
  '((:text mime-text)
    (:image mime-image)
    (:audio mime-audio)
    (:video mime-video)
    (:application mime-application)
    (:multipart mime-multipart)
    (:message mime-message)))

(defgeneric mime-part-size (part)
  (:documentation
   "Return the size in bytes of the body of a MIME part."))

(defgeneric print-mime-part (part stream)
  (:documentation
   "Output to STREAM one of the possible human-readable representation
of mime PART.  Binary parts are omitted.  This function can be used to
quote messages, for instance."))

(defun do-multipart-parts (body-stream part-boundary contents-function end-part-function)
  "Read through BODY-STREAM.  Call CONTENTS-FUNCTION at
each (non-boundary) line or END-PART-FUNCTION at each PART-BOUNDARY."
  (let* ((boundary (s+ "--" part-boundary))
         (boundary-length (length boundary)))
    (labels ((output-line (line)
               (funcall contents-function line))
             (end-part ()
               (funcall end-part-function))
             (last-part ()
               (end-part)
               (return-from do-multipart-parts))
             (process-line (line)
               (cond ((not (string-starts-with boundary line))
                      ;; normal line
                      (output-line line))
                     ((and (= (length (string-trim-whitespace line))
                              (+ 2 boundary-length))
                           (string= "--" line :start2 boundary-length))
                      ;; end of the last part
                      (last-part))
                     ;; according to RFC2046 "the boundary may be followed
                     ;; by zero or more characters of linear whitespace"
                     ((= (length (string-trim-whitespace line)) boundary-length)
                      ;; beginning of the next part
                      (end-part))
                     (t
                      ;; the line boundary is followed by some
                      ;; garbage; we treat it as a normal line
                      (output-line line)))))
      (loop
         for line = (read-line body-stream nil)
         ;; we should never reach the end of a proper multipart MIME
         ;; stream, but we don't want to be fooled by corrupted ones,
         ;; so we check for EOF
         unless line
         do (last-part)
         do (process-line line)))))

(defun index-multipart-parts (body-stream part-boundary)
  "Read from BODY-STREAM and return the file offset of the MIME parts
separated by PART-BOUNDARY."
  (let ((parts '())
        (start 0)
        (len 0)
        (beginning-of-part-p t))
    (flet ((sum-chars (line)
             (incf len (length line))
             ;; account for the #\newline
             (if beginning-of-part-p
                 (setf beginning-of-part-p nil)
                 (incf len)))
           (end-part ()
             (setf beginning-of-part-p t)
             (push (cons start (+ start len)) parts)
             (setf start (file-position body-stream)
                   len 0)))
      (do-multipart-parts body-stream part-boundary #'sum-chars #'end-part)
      ;; the first part is all the stuff up to the first boundary;
      ;; just junk
      (cdr (nreverse parts)))))

(defgeneric encode-mime-part (part stream))
(defgeneric encode-mime-body (part stream))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun write-mime-header (part stream)
  (when (mime-version part)
    (format stream "~&MIME-Version: ~A~%" (mime-version part)))
  (format stream "~&Content-Type: ~A~:{; ~A=~S~}~%" (mime-type-string part)
          (mapcar #'(lambda (pair)
                      (list (car pair) (cdr pair)))
                  (mime-type-parameters part)))
  (awhen (mime-encoding part)
    (format stream "Content-Transfer-Encoding: ~A~%" it))
  (awhen (mime-description part)
    (format stream "Content-Description: ~A~%" it))
  (when (mime-disposition part)
    (format stream "Content-Disposition: ~A~:{; ~A=~S~}~%"
            (mime-disposition part)
            (mapcar #'(lambda (pair)
                        (list (car pair) (cdr pair)))
                    (mime-disposition-parameters part))))
  (awhen (mime-id part)
    (format stream "Content-ID: ~A~%" it))
  (terpri stream))

(defmethod encode-mime-part ((part mime-part) stream)
  (write-mime-header part stream)
  (encode-mime-body part stream))

(defmethod encode-mime-part ((part mime-message) stream)
  ;; tricky: we have to mix the MIME headers with the message headers
  (dolist (h (mime-message-headers part))
    (unless (stringp (car h))
      (setf (car h)
            (string-capitalize (car h))))
    (unless (or (string-starts-with "content-" (car h) #'string-equal)
                (string-equal "mime-version" (car h)))
      (format stream "~A: ~A~%"
              (car h) (cdr h))))
  (encode-mime-part (mime-body part) stream))

(defmethod encode-mime-part ((part mime-multipart) stream)
  ;; choose a boundary if not already set
  (let* ((original-boundary (get-mime-type-parameter part :boundary))
         (boundary (choose-boundary (mime-parts part) original-boundary)))
    (unless (and original-boundary
                 (string= boundary original-boundary))
      (setf (get-mime-type-parameter part :boundary) boundary))
    (call-next-method)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmethod encode-mime-body ((part mime-part) stream)
  (with-input-from-mime-body-stream (in part)
    (encode-stream in stream (mime-encoding part))))

(defmethod encode-mime-body ((part mime-message) stream)
  (encode-mime-body (mime-body part) stream))

(defmethod encode-mime-body ((part mime-multipart) stream)
  (let ((boundary (or (get-mime-type-parameter part :boundary)
                      (setf (get-mime-type-parameter part :boundary)
                            (choose-boundary (mime-parts part))))))
    (dolist (p (mime-parts part))
      (format stream "~%--~A~%" boundary)
      (encode-mime-part p stream))
    (format stream "~%--~A--~%" boundary)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun time-RFC822-string (&optional (epoch (get-universal-time)))
  "Return a string describing the current time according to
the RFC822."
  (multiple-value-bind (ss mm hh day month year week-day dst tz) (decode-universal-time epoch)
    (declare (ignore dst))
    (format nil "~A, ~A ~A ~2,'0D ~2,'0D:~2,'0D:~2,'0D ~:[-~;+~]~2,'0D~2,'0D"
            (subseq (week-day->string week-day) 0 3)
            day (subseq (month->string month) 0 3) (mod year 100) hh mm ss
            (plusp tz) (abs (truncate tz)) (mod (* 60 tz) 60))))

(defun parse-RFC822-date (date-string)
  "Parse a RFC822 compliant date string and return an universal
time."
  ;; if we can't parse it, just return NIL
  (ignore-errors
    ;; skip the optional DoW
    (awhen (position #\, date-string)
      (setf date-string (subseq date-string (1+ it))))
    (destructuring-bind (day month year time &optional tz &rest rubbish)
        (split-at '(#\space #\tab) date-string)
      (declare (ignore rubbish))
      (destructuring-bind (hh mm &optional ss) (split-string-at-char time #\:)
        (encode-universal-time
         (if ss
             (read-from-string ss)
             0)
         (read-from-string mm)
         (read-from-string hh)
         (read-from-string day)
         (1+ (position month
                       '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
                         "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
                       :test #'string-equal))
         (read-from-string year)
         (when (and tz (or (char= #\+ (elt tz 0))
                           (char= #\- (elt tz 0))))
           (/ (read-from-string tz) 100)))))))

(defun read-RFC822-headers (stream &optional required-headers)
  "Read RFC822 compliant headers from STREAM and return them in a
alist of keyword and string pairs.  REQUIRED-HEADERS is a list of
header names we are interested in; if NIL return all headers
found in STREAM."
  ;; the skip-header variable is to avoid the mistake of appending a
  ;; continuation line of a header we don't want to a header we want
  (loop
     with headers = '() and skip-header = nil
     for line = (let ((line (read-line stream nil)))
                  ;; skip the Unix "From " header if present
                  (if (string-starts-with "From " line)
                      (read-line stream nil)
                      line))
     then (read-line stream nil)
     while (and line
                (not (zerop (length line))))
     do (if (whitespace-p (elt line 0))
            (unless (or skip-header
                        (null headers))
              (setf (cdar headers) (s+ (cdar headers) '(#\newline) line)))
            (multiple-value-bind (name value) (parse-RFC822-header line)
              ;; the line contained rubbish instead of an header: we
              ;; play nice and return as we were at the end of the
              ;; headers
              (unless name
                (return (nreverse headers)))
              (if (or (null required-headers)
                      (member name required-headers :test #'string-equal))
                  (progn
                    (push (cons name value) headers)
                    (setf skip-header nil))
                  (setf skip-header t))))
     finally (return (nreverse headers))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric mime-message (thing)
  (:documentation
   "Convert THING to a MIME-MESSAGE object."))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun mime-message-header-values (name message &key decode)
  "Return all values of the header with NAME in MESSAGE, optionally decoding
  it according to RFC2047 if :DECODE is T."
  (loop ;; A header may occur multiple times
        for header in (mime-message-headers message)
        ;; MIME Headers should be case insensitive
        ;; https://stackoverflow.com/a/6143644
        when (string-equal (car header) name)
        collect (if decode
                    (decode-RFC2047 (cdr header))
                    (cdr header))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar *lazy-mime-decode* t
  "If true don't  decode mime bodies in memory.")

(defgeneric decode-mime-body (part input-stream))

(defmethod decode-mime-body ((part mime-part) (stream flexi-stream))
  (let ((base (flexi-stream-root-stream stream)))
    (if *lazy-mime-decode*
        (setf (mime-body part)
              (make-file-portion :data (etypecase base
                                         (vector-stream
                                          (flexi-streams::vector-stream-vector base))
                                         (file-stream
                                          (pathname base)))
                                 :encoding (mime-encoding part)
                                 :start (flexi-stream-position stream)
                                 :end (flexi-stream-bound stream)))
        (call-next-method))))

(defmethod decode-mime-body ((part mime-part) (stream file-stream))
  (if *lazy-mime-decode*
      (setf (mime-body part)
            (make-file-portion :data (pathname stream)
                               :encoding (mime-encoding part)
                               :start (file-position stream)))
      (call-next-method)))

(defmethod decode-mime-body ((part mime-part) (stream vector-stream))
  (if *lazy-mime-decode*
      (setf (mime-body part)
            (make-file-portion :data (flexi-streams::vector-stream-vector stream)
                               :encoding (mime-encoding part)
                               :start (flexi-streams::vector-stream-index stream)))
      (call-next-method)))

(defmethod decode-mime-body ((part mime-part) stream)
  (setf (mime-body part)
        (decode-stream-to-sequence stream (mime-encoding part))))

(defmethod decode-mime-body ((part mime-multipart) stream)
  "Decode STREAM according to PART characteristics and return a
list of MIME parts."
  (save-file-excursion (stream)
    (let ((offsets (index-multipart-parts stream (get-mime-type-parameter part :boundary))))
      (setf (mime-parts part)
            (mapcar #'(lambda (p)
                        (destructuring-bind (start . end) p
                          (let ((*default-type* (if (eq :digest (mime-subtype part))
                                                    '("message" "rfc822" ())
                                                    '("text" "plain" (("charset" . "us-ascii")))))
                                (in (make-positioned-flexi-input-stream stream
                                                                        :position start
                                                                        :bound end
                                                                        :ignore-close t)))
                            (read-mime-part in))))
                    offsets)))))

(defmethod decode-mime-body ((part mime-message) stream)
  "Read from STREAM the body of PART.  Return the decoded MIME
body."
  (setf (mime-body part)
        (read-mime-message stream)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar +known-encodings+ '(:7BIT :8BIT :BINARY :QUOTED-PRINTABLE :BASE64)
  "List of known content encodings.")

(defun keywordify-encoding (string)
  "Return a keyword for a content transfer encoding string.
Return STRING itself if STRING is an unkown encoding."
  (aif (member string +known-encodings+ :test #'string-equal)
       (car it)
       string))

(defun header (name headers)
  (let ((elt (assoc name headers :test #'string-equal)))
    (values (cdr elt) (car elt))))

(defun (setf header) (value name headers)
  (let ((entry (assoc name headers :test #'string-equal)))
    (unless entry
      (error "missing header ~A can't be set" name))
    (setf (cdr entry) value)))

(defun make-mime-part (headers stream)
  "Create a MIME-PART object based on HEADERS and a body which
has to be read from STREAM.  If the mime part type can't be
guessed from the headers, use the *DEFAULT-TYPE*."
  (flet ((hdr (what)
           (header what headers)))
    (destructuring-bind (type subtype parms)
        (or
         (aand (hdr :content-type)
               (parse-content-type it))
         *default-type*)
      (let* ((class (or (cadr (assoc type *mime-types* :test #'string-equal))
                        'mime-unknown-part))
             (disp (aif (hdr :content-disposition)
                        (parse-content-disposition it)
                        (values nil nil)))
             (part (make-instance class
                                  :type (hdr :content-type)
                                  :subtype subtype
                                  :type-parameters parms
                                  :disposition (car disp)
                                  :disposition-parameters (cdr disp)
                                  :mime-version (hdr :mime-version)
                                  :encoding (keywordify-encoding
                                             (hdr :content-transfer-encoding))
                                  :description (hdr :content-description)
                                  :id (hdr :content-id)
                                  :allow-other-keys t)))
        (decode-mime-body part stream)
        part))))

(defun read-mime-part (stream)
  "Read mime part from STREAM.  Return a MIME-PART object."
  (let ((headers (read-rfc822-headers stream
                                      '(:mime-version :content-transfer-encoding :content-type
                                        :content-disposition :content-description :content-id))))
    (make-mime-part headers stream)))

(defun read-mime-message (stream)
  "Main function to read a MIME message from a stream.  It
returns a MIME-MESSAGE object."
  (let ((headers (read-rfc822-headers stream))
        (*default-type* '("text" "plain" (("charset" . "us-ascii")))))
    (flet ((hdr (what)
             (header what headers)))
      (destructuring-bind (type subtype parms)
          (or (aand (hdr :content-type)
                    (parse-content-type it))
              *default-type*)
        (declare (ignore type subtype))
        (make-instance 'mime-message
                       :headers headers
                       ;; this is just for easy access
                       :type-parameters parms
                       :body (make-mime-part headers stream))))))

(defmethod mime-message ((msg mime-message))
  msg)

(defmethod mime-message ((msg string))
  (mime-message (flexi-streams:string-to-octets msg)))

(defmethod mime-message ((msg vector))
  (with-input-from-sequence (in msg)
    (mime-message in)))

(defmethod mime-message ((msg pathname))
  (with-open-file (in msg :element-type '(unsigned-byte 8))
    (mime-message in)))

(defmethod mime-message ((msg stream))
  (mime-message (make-flexi-stream msg)))

(defmethod mime-message ((msg flexi-stream))
  (read-mime-message msg))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric mime-part (object)
  (:documentation
   "Promote object, if necessary, to MIME-PART."))

(defmethod mime-part ((object string))
  (make-instance 'mime-text :subtype "plain" :body object))

(defmethod mime-part ((object pathname))
  (make-instance 'mime-application
                 :subtype "octect-stream"
                 :content-transfer-encoding :base64
                 :body (read-file object :element-type '(unsigned-byte 8))))

(defmethod mime-part ((object mime-part))
  object)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmethod make-encoded-body-stream ((part mime-bodily-part))
  (let ((body (mime-body part)))
    (make-instance (case (mime-encoding part)
                     (:base64
                      'base64-encoder-input-stream)
                     (:quoted-printable
                      'quoted-printable-encoder-input-stream)
                     (otherwise
                      '8bit-encoder-input-stream))
                   :underlying-stream
                   (make-input-adapter body))))

(defun choose-boundary (parts &optional default)
  (labels ((match-in-parts (boundary parts)
             (loop
                for p in parts
                thereis (typecase p
                          (mime-multipart
                           (match-in-parts boundary (mime-parts p)))
                          (mime-bodily-part
                           (match-in-body p boundary)))))
           (match-in-body (part boundary)
             (with-open-stream (in (make-encoded-body-stream part))
               (loop
                  for line = (read-line in nil)
                  while line
                  when (string= line boundary)
                  return t
                  finally (return nil)))))
    (do ((boundary (if default
                       (format nil "--~A" default)
                       #1=(format nil "--~{~36R~}"
                                  (loop
                                     for i from 0 below 20
                                     collect (random 36))))
                   #1#))
        ((not (match-in-parts boundary parts)) (subseq boundary 2)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; fall back method
(defmethod mime-part-size ((part mime-part))
  (let ((body (mime-body part)))
    (typecase body
      (pathname
       (file-size body))
      (string
       (length body))
      (vector
       (length body))
      (t nil))))

(defmethod mime-part-size ((part mime-multipart))
  (loop
     for p in (mime-parts part)
     for size = (mime-part-size p)
     unless size
     return nil
     sum size))

(defmethod mime-part-size ((part mime-message))
  (mime-part-size (mime-body part)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmethod print-mime-part ((part mime-multipart) (out stream))
  (case (mime-subtype part)
    (:alternative
     ;; try to choose something simple to print or the first thing
     (let ((parts (mime-parts part)))
       (print-mime-part (or (find-if #'(lambda (part)
                                         (and (eq (class-of part) (find-class 'mime-text))
                                              (eq (mime-subtype part) :plain)))
                                     parts)
                            (car parts)) out)))
    (otherwise
     (dolist (subpart (mime-parts part))
       (print-mime-part subpart out)))))

;; This is WRONG.  Here we don't use any special character encoding
;; because we don't know which one we should use.  Messages written in
;; anything but ASCII will likely be unreadable -wcp11/10/07.
(defmethod print-mime-part ((part mime-text) (out stream))
  (let ((body (mime-body part)))
    (etypecase body
      (string
       (write-string body out))
      (vector
       (loop
          for byte across body
          do (write-char (code-char byte) out)))
      (file-portion
       (redirect-stream (open-decoded-file-portion body) out))
      (pathname
       (with-open-file (in body)
         (redirect-stream in out))))))

(defmethod print-mime-part ((part mime-message) (out stream))
  (flet ((hdr (name)
           (multiple-value-bind (value tag)
               (header name (mime-message-headers part))
             (cons tag value))))
    (dolist (h (mapcar #'hdr '("from" "subject" "to" "date" "x-march-archive-id")))
      (when h
        (format out "~&~A: ~A" (car h) (cdr h))))
    (format out "~2%")
    (print-mime-part (mime-body part) out)))

(defmethod print-mime-part ((part mime-part) (out stream))
  (format out "~&[ ~A subtype=~A ~@[description=~S ~]~@[size=~A~] ]~%"
          (type-of part) (mime-subtype part) (mime-description part) (mime-part-size part)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric find-mime-part-by-path (mime path)
  (:documentation
   "Return a subpart of MIME identified by PATH, which is a list of
integers.  For example '(2 3 1) is the first part of the third of the
second in MIME."))

(defmethod find-mime-part-by-path ((part mime-part) path)
  (if (null path)
      part
      (error "~S doesn't have subparts" part)))

(defmethod find-mime-part-by-path ((part mime-message) path)
  (if (null path)
      part
      (if (= 1 (car path))
          (find-mime-part-by-path (mime-body part) (cdr path))
          (error "~S may have just one subpart, but part ~D was requested (parts are enumerated base 1)."
                 part (car path)))))

(defmethod find-mime-part-by-path ((part mime-multipart) path)
  (if (null path)
      part
      (let ((parts (mime-parts part))
            (part-number (car path)))
        (if (<= 1 part-number (length parts))
            (find-mime-part-by-path (nth (1- (car path)) (mime-parts part)) (cdr path))
            (error "~S has just ~D subparts, but part ~D was requested (parts are enumerated base 1)."
                   part (length parts) part-number)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric find-mime-part-by-id (part id)
  (:documentation
   "Return a subpart of PAR, whose Content-ID is the same as ID, which
is a string."))

(defmethod find-mime-part-by-id ((part mime-part) id)
  (when (string= id (mime-id part))
    part))

(defmethod find-mime-part-by-id ((part mime-message) id)
  (find-mime-part-by-id (mime-body part) id))

(defmethod find-mime-part-by-id ((part mime-multipart) id)
  (or (call-next-method)
      (some #'(lambda (p)
                (find-mime-part-by-id p id))
            (mime-parts part))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric find-mime-text-part (msg)
  (:documentation
   "Return message if it is a text message or first text part.
   If no suitable text part is found, return NIL."))

(defmethod find-mime-text-part ((part mime-text))
  part) ; found our target

(defmethod find-mime-text-part ((msg mime-message))
  ;; mime-body is either a mime-part or mime-multipart
  (find-mime-text-part (mime-body msg)))

(defmethod find-mime-text-part ((parts mime-multipart))
  ;; multipart messages may have a body, otherwise we
  ;; search for the first text part
  (or (call-next-method)
      (find-if #'find-mime-text-part (mime-parts parts))))

(defmethod find-mime-text-part ((part mime-part))
  nil) ; default case

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric mime-type-string (mime-part)
  (:documentation
   "Return the string describing the MIME part."))

(defmethod mime-type-string ((part mime-unknown-part))
  (mime-type part))

(defmethod mime-type-string ((part mime-text))
  (format nil "text/~A" (mime-subtype part)))

(defmethod mime-type-string ((part mime-image))
  (format nil "image/~A" (mime-subtype part)))

(defmethod mime-type-string ((part mime-audio))
  (format nil "audio/~A" (mime-subtype part)))

(defmethod mime-type-string ((part mime-video))
  (format nil "video/~A" (mime-subtype part)))

(defmethod mime-type-string ((part mime-application))
  (format nil "application/~A" (mime-subtype part)))

(defmethod mime-type-string ((part mime-multipart))
  (format nil "multipart/~A" (mime-subtype part)))

(defmethod mime-type-string ((part mime-message))
  (format nil "message/~A" (mime-subtype part)))

(defmethod mime-type-string ((part mime-unknown-part))
  (mime-type part))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric map-parts (function mime-part)
  (:documentation
   "Recursively map FUNCTION to MIME-PART or its components."))

;; Here we wrongly assume that we'll never want to replace messages
;; and multiparts altogether.  If you need to do so you have to write
;; your own mapping functions.

(defmethod map-parts ((function function) (part mime-part))
  (funcall function part))

(defmethod map-parts ((function function) (part mime-message))
  (setf (mime-body part) (map-parts function (mime-body part)))
  part)

(defmethod map-parts ((function function) (part mime-multipart))
  (setf (mime-parts part) (mapcar #'(lambda (p)
                                      (map-parts function p))
                                  (mime-parts part)))
  part)

;; apply-on-parts is like map-parts but doesn't modify the parts (at least
;; not implicitly)

(defgeneric apply-on-parts (function part))

(defmethod apply-on-parts ((function function) (part mime-part))
  (funcall function part))

(defmethod apply-on-parts ((function function) (part mime-multipart))
  (dolist (p (mime-parts part))
    (apply-on-parts function p)))

(defmethod apply-on-parts ((function function) (part mime-message))
  (apply-on-parts function (mime-body part)))

(defmacro do-parts ((var mime-part) &body body)
  `(apply-on-parts #'(lambda (,var) ,@body) ,mime-part))