;;; guile-email --- Guile email parser
;;; Copyright © 2018, 2019 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 binary-ports)
  #:use-module (ice-9 textual-ports)
  #:use-module (rnrs bytevectors)
  #:use-module ((rnrs io ports)
                #:select (call-with-bytevector-output-port))
  #:use-module (rnrs io simple)
  #:use-module (srfi srfi-26)
  #:export (get-line-with-delimiter
            read-objects
            read-while
            read-bytes-till
            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 and the
end-of-file has not been reached. READ-PROC is invoked with the input
port as argument. PRED is invoked with each string returned by
READ-PROC as argument. The string for which PRED returns #f is ungot
back into PORT."
  (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))
       (else (unget-string port x)))))

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

(define (read-bytes-till port sequence)
  "Read bytes from PORT until byte SEQUENCE is seen or end-of-file is
reached. If SEQUENCE is seen, unget it to PORT and return."
  (define (read-bytes-and-write-till in out sequence)
    (let ((octet (get-u8 in)))
      (cond
       ((eof-object? octet) octet)
       ;; If octet read matches first octet of sequence, try matching
       ;; the full sequence.
       ((= octet (bytevector-u8-ref sequence 0))
        (unget-bytevector in sequence 0 1)
        (let ((bv (get-bytevector-n in (bytevector-length sequence))))
          (cond
           ((bytevector=? bv sequence) (unget-bytevector in bv))
           (else (unget-bytevector in bv 1)
                 (put-u8 out octet)
                 (read-bytes-and-write-till in out sequence)))))
       ;; Else, output the octet and continue reading.
       (else (put-u8 out octet)
             (read-bytes-and-write-till in out sequence)))))

  (let ((bv (call-with-bytevector-output-port
             (cut read-bytes-and-write-till port <> sequence))))
    (if (bytevector=? bv (make-bytevector 0)) (eof-object) bv)))

(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)