diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | debbugs/email.scm | 69 | ||||
| -rw-r--r-- | debbugs/operations.scm | 34 |
3 files changed, 33 insertions, 71 deletions
diff --git a/Makefile.am b/Makefile.am index 0fc86ad..4606e76 100644 --- a/Makefile.am +++ b/Makefile.am @@ -26,7 +26,6 @@ SOURCES = \ debbugs/bug.scm \ debbugs/cache.scm \ debbugs/config.scm \ - debbugs/email.scm \ debbugs/operations.scm \ debbugs/rfc822.scm \ debbugs/soap.scm diff --git a/debbugs/email.scm b/debbugs/email.scm deleted file mode 100644 index b67d7be..0000000 --- a/debbugs/email.scm +++ /dev/null @@ -1,69 +0,0 @@ -;;; Guile-Debbugs --- Guile bindings for Debbugs -;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> -;;; -;;; This file is part of Guile-Debbugs. -;;; -;;; Guile-Debbugs is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU General Public License as -;;; published by the Free Software Foundation; either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; Guile-Debbugs 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 -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with Guile-Debbugs. If not, see <http://www.gnu.org/licenses/>. - -(define-module (debbugs email) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-9 gnu) - #:use-module (srfi srfi-19) - #:use-module (ice-9 match) - #:use-module (debbugs soap) - #:use-module (debbugs rfc822) - #:export (email? - email-headers - email-body - email-attachments - - soap-email->email)) - -(define-record-type <email> - (make-email headers body attachments) - email? - (headers email-headers) - (body email-body) - (attachments email-attachments)) - -(set-record-type-printer! <email> - (lambda (record port) - (simple-format port "#<email ~a>" - (number->string (object-address record) 16)))) - -(define (parse-headers header-text) - "Parse the email headers and return them as an alist." - (with-input-from-string header-text - (lambda () (rfc822-header->list (current-input-port))))) - -(define* (email #:key header body msg-num (attachments '())) - (define (drop-lines str k) - (if (zero? k) - str - (drop-lines (substring str (1+ (string-index str #\newline))) - (1- k)))) - - (make-email (parse-headers (drop-lines header 2)) - body attachments)) - -(define (soap-email->email email-item) - "Convert an SXML expression representing an email item from a SOAP -response to an <email> object." - (let ((email-properties (map soap->scheme (cdr email-item)))) - (apply email - (append-map (match-lambda - ((key . value) - (list (symbol->keyword key) value))) - email-properties)))) diff --git a/debbugs/operations.scm b/debbugs/operations.scm index dda1413..c4cd80f 100644 --- a/debbugs/operations.scm +++ b/debbugs/operations.scm @@ -1,5 +1,6 @@ ;;; Guile-Debbugs --- Guile bindings for Debbugs ;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of Guile-Debbugs. ;;; @@ -19,13 +20,44 @@ (define-module (debbugs operations) #:use-module (debbugs soap) #:use-module (debbugs bug) - #:use-module (debbugs email) + #:use-module (email email) #:use-module (sxml xpath) #:use-module (sxml match) #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:use-module (ice-9 optargs)) +(define (soap-email->email email-item) + "Convert an SXML expression representing an email item from a SOAP +response to an <email> object." + (define (drop-lines str k) + (if (zero? k) + str + (drop-lines (substring str (1+ (string-index str #\newline))) + (1- k)))) + + (let ((email-properties (map soap->scheme (cdr email-item)))) + (let* ((headers (parse-email-headers + (drop-lines (assoc-ref email-properties 'header) 2))) + (content-type (assoc-ref headers 'content-type)) + (body (assoc-ref email-properties 'body))) + (case (assoc-ref content-type 'type) + ((multipart) + (let ((boundary (assoc-ref content-type 'boundary))) + (make-email + headers + ;; Sometimes the debbugs SOAP API provides only the first + ;; MIME entity of a multipart message. This is a bug, and + ;; the following works around it until it can be fixed in + ;; the debbugs SOAP service. + (if (string-contains body (string-append "--" boundary)) + (parse-email-body headers body) + (list (make-mime-entity + `(content-type (type . text) + (subtype . plain)) + body)))))) + (else (make-email headers body)))))) + (define-public (newest-bugs amount) "Return a list of bug numbers corresponding to the newest AMOUNT bugs." |