utils.scm 1.9 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849
  1. ;;; guile-gcrypt --- crypto tooling for guile
  2. ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
  3. ;;;
  4. ;;; This file is part of guile-gcrypt.
  5. ;;;
  6. ;;; guile-gcrypt is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 3 of the License, or
  9. ;;; (at your option) any later version.
  10. ;;;
  11. ;;; guile-gcrypt is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  14. ;;; General Public License for more details.
  15. ;;;
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with guile-gcrypt. If not, see <http://www.gnu.org/licenses/>.
  18. (define-module (gcrypt utils)
  19. #:use-module (rnrs bytevectors)
  20. #:use-module (rnrs io ports)
  21. #:export (dump-port))
  22. (define* (dump-port in out
  23. #:key (buffer-size 16384)
  24. (progress (lambda (t k) (k))))
  25. "Read as much data as possible from IN and write it to OUT, using chunks of
  26. BUFFER-SIZE bytes. Call PROGRESS at the beginning and after each successful
  27. transfer of BUFFER-SIZE bytes or less, passing it the total number of bytes
  28. transferred and the continuation of the transfer as a thunk."
  29. (define buffer
  30. (make-bytevector buffer-size))
  31. (define (loop total bytes)
  32. (or (eof-object? bytes)
  33. (let ((total (+ total bytes)))
  34. (put-bytevector out buffer 0 bytes)
  35. (progress total
  36. (lambda ()
  37. (loop total
  38. (get-bytevector-n! in buffer 0 buffer-size)))))))
  39. ;; Make sure PROGRESS is called when we start so that it can measure
  40. ;; throughput.
  41. (progress 0
  42. (lambda ()
  43. (loop 0 (get-bytevector-n! in buffer 0 buffer-size)))))