PasteRack.org
Paste # 5961
2017-01-29 10:30:46

Fork as a new paste.

Paste viewed 727 times.


Embed:

imapfilter by Huang, Ying

  1. #!/usr/bin/racket
  2. #lang racket
  3.  
  4. (require net/imap)
  5.  
  6. (define (messages-filter messages start pattern)
  7.   (for/fold ([result empty])
  8.             ([msg messages]
  9.              [num (in-naturals start)])
  10.     (let ([header (car msg)])
  11.       (if (regexp-match? pattern header)
  12.           (cons num result)
  13.           result))))
  14.  
  15. (define (messages-remove messages start to-remove-msg-nums)
  16.   (reverse
  17.    (for/fold ([result empty])
  18.              ([msg messages]
  19.               [num (in-naturals start)])
  20.      (if (member num to-remove-msg-nums eqv?)
  21.          result
  22.          (cons msg result)))))
  23.  
  24. (define (header-contain header pattern)
  25.   (regexp (format "(?im:^~a: .*~a.*$)" header pattern)))
  26.  
  27. (define (imap-fetch imap total start len)
  28.   (let* ([end (min (add1 total) (+ start len))]
  29.          [msg-nums (sequence->list (in-range start end))])
  30.     (when (pair? msg-nums)
  31.       (imap-get-messages imap msg-nums '(header)))))
  32.  
  33. (define (imap-get-expunges-number imap)
  34.   (length (imap-get-expunges imap)))
  35.  
  36. (define (imap-filter-move imap total . pattern_dest-mailboxes)
  37.   (let filter-move ([start 1]
  38.                     [total total])
  39.     (define (call-with-check-expunges thk cont)
  40.       (let* ([val-list (call-with-values thk list)]
  41.              [expunges-number (imap-get-expunges-number imap)])
  42.         (if (> expunges-number 0)
  43.           (filter-move (- start expunges-number)
  44.                        (- total expunges-number))
  45.           (apply cont val-list))))
  46.     (when (and (> total 0)
  47.                (<= start total)
  48.                (pair? pattern_dest-mailboxes))
  49.       (let ([start (max start 1)])
  50.         (call-with-check-expunges
  51.          (thunk (imap-fetch imap total start batch))
  52.          (λ (msgs)
  53.           (let loop ([pds pattern_dest-mailboxes]
  54.                      [total total]
  55.                      [msgs msgs])
  56.             (if (and (pair? pds) (pair? msgs))
  57.                 (let* ([pattern_dest-mailbox (car pds)]
  58.                        [pattern (first pattern_dest-mailbox)]
  59.                        [dest-mailbox (second pattern_dest-mailbox)]
  60.                        [tm-msg-nums (messages-filter msgs start pattern)])
  61.                   (if (pair? tm-msg-nums)
  62.                       (call-with-check-expunges
  63.                        (thunk (imap-copy imap tm-msg-nums dest-mailbox))
  64.                        (λ (v)
  65.                          (imap-store imap '+ tm-msg-nums
  66.                                      (list (symbol->imap-flag 'deleted)))
  67.                          (imap-expunge imap)
  68.                          (let ([expunges-number (imap-get-expunges-number imap)])
  69.                            (if (= expunges-number (length tm-msg-nums))
  70.                                (loop (cdr pds) (- total expunges-number)
  71.                                      (messages-remove msgs start tm-msg-nums))
  72.                                (filter-move (- start expunges-number)
  73.                                             (- total expunges-number))))))
  74.                       (loop (cdr pds) total msgs)))
  75.                 (filter-move (+ start (length msgs)) total)))))))))
  76.  
  77. (define server "imap.your-server.com")
  78. (define port 993)
  79. (define username "your user name")
  80. (define password "your password")
  81. (define mailbox-name "your INBOX")
  82. (define batch 10)
  83.  
  84. (define (connect)
  85.   (parameterize ([imap-port-number port])
  86.     (imap-connect server username password
  87.                   mailbox-name #:tls? #t)))
  88.  
  89. (define (main)
  90.   (define-values (imap total recent) (connect))
  91.   (dynamic-wind
  92.     values
  93.     (thunk
  94.      (imap-filter-move imap total
  95.                        `(,(header-contain "Mailing-list"
  96.                                           "racket-users@googlegroups.com")
  97.                          "racket-user")
  98.                        `(,(header-contain "Mailing-list"
  99.                                           "users@plt-scheme.org")
  100.                          "racket-user")
  101.                        `(,(header-contain "Mailing-list"
  102.                                           "racket-dev@googlegroups.com")
  103.                          "racket-devel")
  104.                        `(,(header-contain "Mailing-list"
  105.                                           "dev@plt-scheme.org")
  106.                          "racket-devel")))
  107.     (thunk (imap-disconnect imap))))
  108.  
  109. (main)

=>

tcp-connect: network access denied: '("imap.your-server.com"

993 client)