aboutsummaryrefslogtreecommitdiff
path: root/email/utils.scm
blob: e942fc286eda978ffb1fb1ac8b589cc0d71bc299 (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
;;; guile-email --- Guile email parser
;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of guile-email.
;;;
;;; guile-email is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU Affero General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; guile-email 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
;;; Affero General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with guile-email.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (email utils)
  #:use-module (ice-9 match)
  #:use-module (ice-9 peg codegen)
  #:use-module (ice-9 textual-ports)
  #:use-module (rnrs io simple)
  #:export (get-line-with-delimiter
            read-objects
            read-while
            acons*
            alist-delete*))

(define (read-objects read-proc port)
  "Read all objects using READ-PROC from PORT and return them as a
list."
  (let ((x (read-proc port)))
    (if (eof-object? x)
        (list)
        (cons x (read-objects read-proc port)))))

(define* (read-while port read-proc pred)
  "Read from PORT using READ-PROC while PRED returns #t. READ-PROC is
invoked with the input port as argument. PRED is invoked with each
string returned by READ-PROC as argument."
  (define (read-while-loop output)
    (let ((x (read-proc port)))
      (cond
       ((eof-object? x) x)
       ((pred x)
        (put-string output x)
        (read-while-loop output))
       (#t (unget-string port x)))))

  (let ((str (call-with-output-string read-while-loop)))
    (if (string-null? str) (eof-object) str)))

(define (get-line-with-delimiter port)
  "Read a line from PORT and return it as a string including the
delimiting linefeed character."
  (let ((line (get-line port)))
    (if (eof-object? line)
        line
        (string-append line "\n"))))

(define acons*
  (match-lambda*
    ((key value)
     (acons key value (list)))
    ((key value . rest)
     (acons key value (apply acons* rest)))
    ((alist) alist)))

(define (alist-delete* keys alist)
  "Return a list containing all elements of ALIST whose keys are not a
member of KEYS."
  (filter (match-lambda
            ((key . _)
             (not (member key keys))))
          alist))

(define (cg-string-ci pat accum)
  (syntax-case pat ()
    ((pat-str-syntax) (string? (syntax->datum #'pat-str-syntax))
     (let ((pat-str (syntax->datum #'pat-str-syntax)))
       (let ((plen (string-length pat-str)))
         #`(lambda (str len pos)
             (let ((end (+ pos #,plen)))
               (and (<= end len)
                    (string-ci= str #,pat-str pos end)
                    #,(case accum
                        ((all) #`(list end (list 'cg-string #,pat-str)))
                        ((name) #`(list end 'cg-string))
                        ((body) #`(list end #,pat-str))
                        ((none) #`(list end '()))
                        (else (error "bad accum" accum)))))))))))

(add-peg-compiler! 'string-ci cg-string-ci)