gnu/tests/mail.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016 Sou Bunnbu <iyzsong@member.fsf.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix 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 (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix 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
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu tests mail)
  20   #:use-module (gnu tests)
  21   #:use-module (gnu system)
  22   #:use-module (gnu system file-systems)
  23   #:use-module (gnu system grub)
  24   #:use-module (gnu system vm)
  25   #:use-module (gnu services)
  26   #:use-module (gnu services base)
  27   #:use-module (gnu services mail)
  28   #:use-module (gnu services networking)
  29   #:use-module (guix gexp)
  30   #:use-module (guix monads)
  31   #:use-module (guix store)
  32   #:export (%test-opensmtpd))
  33
  34 (define %opensmtpd-os
  35   (operating-system
  36     (host-name "komputilo")
  37     (timezone "Europe/Berlin")
  38     (locale "en_US.UTF-8")
  39     (bootloader (grub-configuration (device #f)))
  40     (file-systems %base-file-systems)
  41     (firmware '())
  42     (services (cons*
  43                (dhcp-client-service)
  44                (service opensmtpd-service-type
  45                         (opensmtpd-configuration
  46                          (config-file
  47                           (plain-file "smtpd.conf" "
  48 listen on 0.0.0.0
  49 accept from any for local deliver to mbox
  50 "))))
  51                %base-services))))
  52
  53 (define (run-opensmtpd-test)
  54   "Return a test of an OS running OpenSMTPD service."
  55   (mlet* %store-monad ((command (system-qemu-image/shared-store-script
  56                                  (marionette-operating-system
  57                                   %opensmtpd-os
  58                                   #:imported-modules '((gnu services herd)))
  59                                  #:graphic? #f)))
  60     (define test
  61       (with-imported-modules '((gnu build marionette))
  62         #~(begin
  63             (use-modules (rnrs base)
  64                          (srfi srfi-64)
  65                          (ice-9 rdelim)
  66                          (ice-9 regex)
  67                          (gnu build marionette))
  68
  69             (define marionette
  70               (make-marionette
  71                ;; Enable TCP forwarding of the guest's port 25.
  72                '(#$command "-net" "user,hostfwd=tcp::1025-:25")))
  73
  74             (define (read-reply-code port)
  75               "Read a SMTP reply from PORT and return its reply code."
  76               (let* ((line      (read-line port))
  77                      (mo        (string-match "([0-9]+)([ -]).*" line))
  78                      (code      (string->number (match:substring mo 1)))
  79                      (finished? (string= " " (match:substring mo 2))))
  80                 (if finished?
  81                     code
  82                     (read-reply-code port))))
  83
  84             (mkdir #$output)
  85             (chdir #$output)
  86
  87             (test-begin "opensmptd")
  88
  89             (test-assert "service is running"
  90               (marionette-eval
  91                '(begin
  92                   (use-modules (gnu services herd))
  93                   (start-service 'smtpd)
  94                   #t)
  95                marionette))
  96
  97             (test-assert "mbox is empty"
  98               (marionette-eval
  99                '(and (file-exists? "/var/mail")
 100                      (not (file-exists? "/var/mail/root")))
 101                marionette))
 102
 103             (test-eq "accept an email"
 104               #t
 105               (let* ((smtp (socket AF_INET SOCK_STREAM 0))
 106                      (addr (make-socket-address AF_INET INADDR_LOOPBACK 1025)))
 107                 (connect smtp addr)
 108                 ;; Be greeted.
 109                 (read-reply-code smtp)             ;220
 110                 ;; Greet the server.
 111                 (write-line "EHLO somehost" smtp)
 112                 (read-reply-code smtp)             ;250
 113                 ;; Set sender email.
 114                 (write-line "MAIL FROM: <someone>" smtp)
 115                 (read-reply-code smtp)             ;250
 116                 ;; Set recipient email.
 117                 (write-line "RCPT TO: <root>" smtp)
 118                 (read-reply-code smtp)             ;250
 119                 ;; Send message.
 120                 (write-line "DATA" smtp)
 121                 (read-reply-code smtp)             ;354
 122                 (write-line "Subject: Hello" smtp)
 123                 (newline smtp)
 124                 (write-line "Nice to meet you!" smtp)
 125                 (write-line "." smtp)
 126                 (read-reply-code smtp)             ;250
 127                 ;; Say goodbye.
 128                 (write-line "QUIT" smtp)
 129                 (read-reply-code smtp)             ;221
 130                 (close smtp)
 131                 #t))
 132
 133             (test-assert "mail arrived"
 134               (marionette-eval
 135                '(begin
 136                   (use-modules (ice-9 popen)
 137                                (ice-9 rdelim))
 138
 139                   (define (queue-empty?)
 140                     (eof-object?
 141                      (read-line
 142                       (open-input-pipe "smtpctl show queue"))))
 143
 144                   (let wait ()
 145                     (if (queue-empty?)
 146                         (file-exists? "/var/mail/root")
 147                         (begin (sleep 1) (wait)))))
 148                marionette))
 149
 150             (test-end)
 151             (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
 152
 153     (gexp->derivation "opensmtpd-test" test)))
 154
 155 (define %test-opensmtpd
 156   (system-test
 157    (name "opensmtpd")
 158    (description "Send an email to a running OpenSMTPD server.")
 159    (value (run-opensmtpd-test))))