├── .github └── workflows │ └── ci.yml ├── .gitignore ├── README.md ├── benchmark ├── .gitignore ├── attack.rkt ├── plot.rkt └── server.rkt ├── example ├── client.rkt ├── example.crt ├── example.key └── server.rkt ├── smtp-server-test ├── LICENSE ├── info.rkt └── net │ ├── smtp-server-example.crt │ ├── smtp-server-example.key │ └── smtp-server.rkt └── smtp-server ├── LICENSE ├── info.rkt ├── scribblings └── smtp-server.scrbl └── smtp-server.rkt /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | on: [push, pull_request] 2 | name: CI 3 | jobs: 4 | build: 5 | runs-on: ubuntu-20.04 6 | strategy: 7 | fail-fast: false 8 | matrix: 9 | racket-variant: [ 'BC', 'CS' ] 10 | racket-version: [ '8.9', 'current' ] 11 | include: 12 | - racket-version: current 13 | allow-fail: true 14 | name: Build and Test on Racket ${{ matrix.racket-variant }} ${{ matrix.racket-version }} 15 | steps: 16 | - uses: actions/checkout@master 17 | - name: Setup Racket 18 | uses: Bogdanp/setup-racket@v1.9 19 | with: 20 | architecture: x64 21 | version: ${{ matrix.racket-version }} 22 | variant: ${{ matrix.racket-variant }} 23 | - run: raco pkg install --batch --auto smtp-server/ smtp-server-test/ 24 | - run: raco test -l tests/net/smtp-server 25 | continue-on-error: ${{ matrix.allow-fail || false }} 26 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | compiled/ 2 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # smtp-server 2 | 3 | An implementation of [RFC5321] for Racket. 4 | 5 | ## Usage 6 | 7 | ``` racket 8 | (define stop 9 | (start-smtp-server println)) 10 | ``` 11 | 12 | ## License 13 | 14 | smtp-server is licensed under the 3-Clause BSD license. 15 | 16 | 17 | [RFC5321]: https://www.ietf.org/rfc/rfc5321.html 18 | -------------------------------------------------------------------------------- /benchmark/.gitignore: -------------------------------------------------------------------------------- 1 | *.log -------------------------------------------------------------------------------- /benchmark/attack.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/tcp) 4 | 5 | (define (write* bs out) 6 | (write-bytes bs out) 7 | (flush-output out)) 8 | 9 | (define (expect in s) 10 | (define s-read (read-line in 'return-linefeed)) 11 | (unless (equal? s-read s) 12 | (error 'expect "expected ~s but received ~s" s s-read))) 13 | 14 | (define (start-attacker stats-ch) 15 | (let outer-loop () 16 | (with-handlers ([exn:break? void] 17 | [exn:fail? (λ (err) 18 | ((error-display-handler) (exn-message err) err) 19 | (channel-put stats-ch 'err) 20 | (outer-loop))]) 21 | (define-values (in out) 22 | (tcp-connect "127.0.0.1" 8675)) 23 | (void (read-line in)) 24 | (let loop () 25 | (write* #"MAIL FROM:\r\n" out) 26 | (expect in "250 OK") 27 | (write* #"RCPT TO:\r\n" out) 28 | (expect in "250 OK") 29 | (write* #"DATA\r\n" out) 30 | (expect in "354 end data with .") 31 | (write* #"Hello, world!\r\n.\r\n" out) 32 | (expect in "250 OK") 33 | (channel-put stats-ch 'ok) 34 | (loop))))) 35 | 36 | (define (attack! concurrency duration) 37 | (define stats-ch (make-channel)) 38 | (define stats-thd 39 | (thread 40 | (lambda () 41 | (let loop ([total 0] [failed 0] [alarm (alarm-evt (+ (current-inexact-milliseconds) 1000))]) 42 | (sync 43 | (handle-evt 44 | alarm 45 | (lambda (_) 46 | (printf "total: ~a failed: ~a~n" total failed) 47 | (loop total failed (alarm-evt (+ (current-inexact-milliseconds) 1000))))) 48 | (handle-evt 49 | stats-ch 50 | (lambda (message) 51 | (case message 52 | [(ok) (loop (add1 total) failed alarm)] 53 | [(err) (loop (add1 total) (add1 failed) alarm)])))))))) 54 | (define thds 55 | (for/list ([_ (in-range concurrency)]) 56 | (thread 57 | (lambda () 58 | (start-attacker stats-ch))))) 59 | (sleep duration) 60 | (for-each break-thread thds) 61 | (for-each thread-wait thds) 62 | (break-thread stats-thd)) 63 | 64 | (module+ main 65 | (require racket/cmdline) 66 | (define-values (concurrency duration) 67 | (let ([concurrency 1000] 68 | [duration 60]) 69 | (command-line 70 | #:once-each 71 | [("--concurrency" "-c") CONCURRENCY "the number of concurrent connections to run" 72 | (define concurrency-num (string->number CONCURRENCY)) 73 | (unless concurrency 74 | (eprintf "error: CONCURRENCY must be a positive integer~n") 75 | (exit 1)) 76 | (set! concurrency concurrency-num)] 77 | [("--duration" "-d") DURATION "how long to attack the server for (in seconds)" 78 | (define duration-num (string->number DURATION)) 79 | (unless (and duration (> duration 0)) 80 | (eprintf "error: DURATION must be a positive integer~n") 81 | (exit 1)) 82 | (set! duration duration-num)] 83 | #:args [] 84 | (values concurrency duration)))) 85 | (attack! concurrency duration)) 86 | -------------------------------------------------------------------------------- /benchmark/plot.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require plot 4 | racket/cmdline 5 | racket/match 6 | racket/string) 7 | 8 | (define filenames 9 | (command-line 10 | #:args filenames 11 | filenames)) 12 | 13 | (define (read-log filename) 14 | (call-with-input-file filename 15 | (lambda (in) 16 | (filter values (for/list ([line (in-lines in)]) 17 | (match line 18 | [(regexp "GC: 0:.* @ ([^K]+)K.*; free .* @ (.+)" (list _ ks ts)) 19 | (list (string->number ts) 20 | (round (/ (string->number (string-replace ks "," "")) 1024)))] 21 | [_ 22 | #f])))))) 23 | 24 | (parameterize ([plot-new-window? #t] 25 | [plot-width 800] 26 | [plot-height 600] 27 | [plot-x-label "Milliseconds"] 28 | [plot-y-label "MiB"]) 29 | (plot (for/list ([(filename idx) (in-indexed (in-list filenames))]) 30 | (lines 31 | #:label filename 32 | #:color idx 33 | (read-log filename))))) 34 | -------------------------------------------------------------------------------- /benchmark/server.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require net/smtp-server) 4 | 5 | (define stop 6 | (start-smtp-server 7 | #:host "127.0.0.1" 8 | #:port 8675 9 | void)) 10 | 11 | (with-handlers ([exn:break? (λ (_) (stop))]) 12 | (sync never-evt)) 13 | -------------------------------------------------------------------------------- /example/client.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require net/head 4 | net/smtp 5 | openssl 6 | racket/cmdline) 7 | 8 | (define-values (subject sender recipients) 9 | (let ([the-subject "Hello!"]) 10 | (command-line 11 | #:once-each 12 | [("--subject") subject "the e-mail subject line (default: 'Hello!')" (set! the-subject subject)] 13 | #:args [sender . recipients] 14 | (values the-subject sender recipients)))) 15 | 16 | (define lines 17 | (for/list ([line (in-lines (current-input-port))]) 18 | line)) 19 | 20 | (smtp-send-message 21 | #:port-no 8675 22 | #:tls-encode ports->ssl-ports 23 | "127.0.0.1" 24 | sender 25 | recipients 26 | (insert-field 27 | "To" (assemble-address-field recipients) 28 | (insert-field "Subject" subject empty-header)) 29 | lines) 30 | -------------------------------------------------------------------------------- /example/example.crt: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIIFbzCCA1egAwIBAgIUHd9QzglpbaXTkrJ74ooNoEfs6vcwDQYJKoZIhvcNAQEL 3 | BQAwRzELMAkGA1UEBhMCUk8xDTALBgNVBAgMBENsdWoxFDASBgNVBAcMC0NsdWot 4 | TmFwb2NhMRMwEQYDVQQKDApFeGFtcGxlIENvMB4XDTIxMTEwMTA4MzczM1oXDTMx 5 | MTAzMDA4MzczM1owRzELMAkGA1UEBhMCUk8xDTALBgNVBAgMBENsdWoxFDASBgNV 6 | BAcMC0NsdWotTmFwb2NhMRMwEQYDVQQKDApFeGFtcGxlIENvMIICIjANBgkqhkiG 7 | 9w0BAQEFAAOCAg8AMIICCgKCAgEAwncErewKHoPEWESQXnHknme2shjryijv/IkY 8 | n7FTv60aVGZqNhXtZK60xCTAXDuzzyCF5K95czRJPGi6TtPpF3LkDhCUS4bEMkhC 9 | pFh6RxAKOTF/pW7XUc8X2NoxlTD7xMLJ5KQlzMCS7NKZsn5ZNcwrEDapnxA3WeSS 10 | EdiLwvDRLnrHcladwyE2O+ib3F66mfKzi4LmBT6de8FjCUs+3CRe5HFAmtGMNXrd 11 | YrxP+tCMS4A08joUXPlr56WXwNkSN+N+O9+TNvaQUbo5D/LSFHyoS6HMmbVakvny 12 | S/6nwqVa5UunuHJCBrGbcq76Ei6ar142OMoIyDTxa5OFcnvKB0Nxi7AsMPpNisn+ 13 | PBP4h9kLUJNpUFSLlyHnGYZgoTDU5gqfzdwZJAFmqGH9wYgKQL9WzL2MA4+jmmxM 14 | 5C1YD4TU8EbsK6M5GBOMOi2Y5SRWXlHHO4u0TZUeTiAcwgCQVBMC5dtcvhnTQtZ+ 15 | Lsu2YE/iaQblef16svkqL/r7mxF45ENs9nldyn+OX0p9PRqcu8DUajm9lZXlX472 16 | TdgRj8Mg5S3wiMsEgpxnPBrJ6mtNF0jthKH+bvH+/sC7vPKLR70rib6LabewZ3AQ 17 | gw+BjAxGWMHGE97vWs3aA2kpLyZdpVsElwYz2Nu/RlwA4RJj4t/sAzJn4IVkl8Ns 18 | APWZLrkCAwEAAaNTMFEwHQYDVR0OBBYEFOcU2TBYIP6FkoR5REM0rhKrKWHOMB8G 19 | A1UdIwQYMBaAFOcU2TBYIP6FkoR5REM0rhKrKWHOMA8GA1UdEwEB/wQFMAMBAf8w 20 | DQYJKoZIhvcNAQELBQADggIBAEG9YEAMTI5Tzsfz/s/3YSJIT0GD25epDImHg9vg 21 | nGH3vLPGzsTUawoLG5FB2HOdd+dgbwU0Zyh4DxMpoh7YU8oV2JrWFx+P/9zpehRT 22 | KNCyv3LeBkOl3MtbZn861PfhxLvOWbC/CNy4CizooleCNJHS99ceIxGDChbFMWC7 23 | npK/yllE5x5BSBDnOeQ0vLyH8kxWxB7ZFKFnrDd3sseeuetP0z1iJdXeTscA099p 24 | kJ6ZlV94z/Cpey5zZgyalXSDi2HytUwPcvCr0qBS9K/0CbuXqZTzejaFHVvqy7ob 25 | P+QQh0c4pDPyQgFDDjxjsgCcLtktsWC6At7sJDxyxgDsuFyisaWuUNFV1CUH5D+a 26 | 1Q9acfC7Omh+11NwFl3b52IOF7w+h3uZBqNUkK4oSdc4isMhNCsKTYba8pdv5H9B 27 | gJdoVoLA94jFZDG/ffrAhmKKGsl1UEHme+f9BKxQBhcMEpkpVFgdMMmPcpcRGeoo 28 | dMvF0ZezqJPSAyXq/epd0oHmz5ZwaG2nqYrPhSPeh2M1kZLcLCXpau3mP81o4n5I 29 | yqiZruMrGPjtex7CEgIq/DppK5T1E0Vfu/PmbUufQVubceHdNuruP35Ep6rRg9nG 30 | TBCGheOMq088wPKfyWqbtj4/RL36ZpDDG5rCI0/c6P7G4gTfCE7WG1h7Bkz0HPk5 31 | UwiP 32 | -----END CERTIFICATE----- 33 | -------------------------------------------------------------------------------- /example/example.key: -------------------------------------------------------------------------------- 1 | -----BEGIN PRIVATE KEY----- 2 | MIIJQQIBADANBgkqhkiG9w0BAQEFAASCCSswggknAgEAAoICAQDCdwSt7Aoeg8RY 3 | RJBeceSeZ7ayGOvKKO/8iRifsVO/rRpUZmo2Fe1krrTEJMBcO7PPIIXkr3lzNEk8 4 | aLpO0+kXcuQOEJRLhsQySEKkWHpHEAo5MX+lbtdRzxfY2jGVMPvEwsnkpCXMwJLs 5 | 0pmyflk1zCsQNqmfEDdZ5JIR2IvC8NEuesdyVp3DITY76JvcXrqZ8rOLguYFPp17 6 | wWMJSz7cJF7kcUCa0Yw1et1ivE/60IxLgDTyOhRc+WvnpZfA2RI3434735M29pBR 7 | ujkP8tIUfKhLocyZtVqS+fJL/qfCpVrlS6e4ckIGsZtyrvoSLpqvXjY4ygjINPFr 8 | k4Vye8oHQ3GLsCww+k2Kyf48E/iH2QtQk2lQVIuXIecZhmChMNTmCp/N3BkkAWao 9 | Yf3BiApAv1bMvYwDj6OabEzkLVgPhNTwRuwrozkYE4w6LZjlJFZeUcc7i7RNlR5O 10 | IBzCAJBUEwLl21y+GdNC1n4uy7ZgT+JpBuV5/Xqy+Sov+vubEXjkQ2z2eV3Kf45f 11 | Sn09Gpy7wNRqOb2VleVfjvZN2BGPwyDlLfCIywSCnGc8Gsnqa00XSO2Eof5u8f7+ 12 | wLu88otHvSuJvotpt7BncBCDD4GMDEZYwcYT3u9azdoDaSkvJl2lWwSXBjPY279G 13 | XADhEmPi3+wDMmfghWSXw2wA9ZkuuQIDAQABAoICAEiWgqGlHPXc+5pzJWyLmOnk 14 | DtcV5FXWyBX82rspRviiVdSxUe4Ua0OMzx70FPWYt3qWSkRdl7kACGJLOVgZU8WT 15 | 9jqlx6UVjgCy5mVQPXxvKVHF/z6yTB9WbTFd6OommaQNja0R9KYkL/PEfOiarxQc 16 | vOpVbSVZuT+NyVRt/2Vp3Ls7y10LpeHjcMoV/q/YkFDMvmZSGyhUAhbizeP3OWSV 17 | EvK0r4fatjp0PVUQs84MsIGyPpE4SseVtsiGEEpE/L7t5P3Wa641hRNsrsYcPny1 18 | N2Db6XJqtn9sWxww11AZxv8WKWn5BFpZS4wYcnH9AXJ6eUTjbTnGQWOFcmeUe4lo 19 | lAj5bJ5b7Wuzk43QO7uXOcsgvfz/l3xsxTWysLXx7lGhH7Fk4qO84TpqFvtb5Dz3 20 | GFhLKASEXfT8S7xq9Z03RglE5fDM4ENDbqmBycWgSdaRsE2WHmczDfqBunCxtiOT 21 | QxaDieYAtfubNSobSt3CXoFkMAnh5PfVrq5GM3EizbUU7+veZglgNpZu8WqEHz41 22 | SdpyiG4PqOnzFywG/yVEw5rbpqXb4I01jLifRjYRNzCsDu6GDknrK8OJQpkuPdTh 23 | cIZyBHw4FQj8jEOi6jpXf2sAG5BP56587OQpAQsmGByTJ+Vwltz0Dt/NQORTnKHX 24 | WwVI+VPMVyJT06fwcZRdAoIBAQD9+JXcDB320iQutsbo6QJUtXFAWQEggEy8xfVP 25 | 89vyFlPRtK+eNjzCo7eTvebjZvpfyAERgXiFHjGjtORZD+N2EiOVJ5x0FIEy9Wen 26 | 18WckvTzOjY3fnXERJg4RxRv99vHGe3V8LrAqXzu3Guh8bZxVyTqEq6iRR3HPZKv 27 | y4caF5M54ny/82TdbufwQiOsWxCQIRAALN51nKSpSe9o3SYJT6CBQCitOyk6oYZA 28 | f4WtXFwv5wiF+Yqv3xoIB6UdJFvpUCimUp+/TK694jHu7jhv1m/70x2lDfdG4hYK 29 | v5MAGPdDSAMOu5YBVf7Amy9q8852uMNaOvAnDdkfzuuk21erAoIBAQDEBLuLoSje 30 | awb9Z5ykwqYq4OICILs5pe20rRUEzpwMisZtL8hZ6SJAKgQEA2pOE8szBDTWflmP 31 | QGFBuf3wM54P633Pwfeaitbct8wqZ4T0UfQzOl34wjmKqUi9c+63jBj39w6I6wdp 32 | p+QtbIZTm1EQDNVDKXEpOHlSC7daLSTytujCaWinInblxzMQb02noIHxZgKOrTnE 33 | fL5/O3aNz/rM0qSiSsnY1xlWHYISr+NMb8ZFg+jcD3C+Qtv+XbusA4Elj83Gs69U 34 | 2oxhzF1WeHX4R1JWIy3cySigBGZ9QrX0RnkV9pFNtPYwYZmblA6uQuNXeWtmH7lr 35 | 4Yg4/6Hwq18rAoIBACjcRcARcwCy7n9ViMsQMf/O8VmY+EVyXuZAMyeZ5Fkenn2u 36 | xFKAB2aJUI/EjdEoUD/4vbNDUVCZewMLp3FszPvCD1d/9/v1EJRSR0sJvBFk02QO 37 | iYqEHg5lutfTF8ar6gAue8Vf5av5mNAVRnvXl7LEgnvmZZJV7GSR03fVFvdrs5Qs 38 | jEWVszStE0PkYDjqrc+CgkCE94WUnilea9ZDPkthNEGXQPQeAJQeSKs32Rn7MhnC 39 | 4ewsKdQB4P5JvJbjsqXm76NSx8DPZY3HRqFaUlor9fheDvbvOEl/NmykRdJOMfnx 40 | LAzCwW+VllcGoKpkb2NKdqOdt+WQpM4pTGBJqeECggEAKLmS/X+OLieuXBeaw+Bt 41 | BZuTWT3TqDaBHHiZVVZXtYNflm/HAGcfZpVUIEFVZMNYBFFraOT3VnvZuP4bdDxF 42 | KqmSigeSmdkeqtzE3kqDpP8h7ULDI1u2+MgTBMmBX0EMLvh1XJz3/UuUbJuPjO9H 43 | +D2yUTHbAOVqz1D/1wxqEMNPuJSN2aufaD3qrg9x4tHGLZE0FtCGn/wK2ARSrUP4 44 | p3VcHxvKs/J8oRegXqGMZ+URHIA7cP0EP4NEkaSHyUUxH8ywxAew9cAySl9bRQvh 45 | 9qNax+qnLKfeeOBxKrUheI7ruVRw++QNAiBE+b3ZDvt2oEXpul38+BzzYGQ8EPSJ 46 | 4QKCAQBeOnLvvVpGfkEIeKbjpKmsg7S7hlzIejQBeltnJXxGp7m91dmuWnQxmDXQ 47 | 1Taq00MxLOGBIx8Me6lmNdaKIWLU4PTiajInoicyueBYdYYNYwsmoBYFnhklNy66 48 | IpH4yQO0Wu2TWoJzpiDrXWDXEmILH48byCB4AtaiCOq7Wuy2QbV+oxtWcpn1fp+s 49 | M2M5OQ36i2abeIjSMF5+T1J38cFP22x8tRfPjUom8WjM3NWLZWjIQ3abKu2QVZs/ 50 | TkAJJ/skzJAGDYHfQ2eS7ZUTGnWqAjgnYuYSefC/BSJgQsT5VAjSgZ76V0DkZiLE 51 | /f6c14Ml/pXUNg37wvaK4CjHUHrS 52 | -----END PRIVATE KEY----- 53 | -------------------------------------------------------------------------------- /example/server.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require net/mime 4 | net/smtp-server 5 | openssl 6 | racket/port 7 | racket/pretty 8 | racket/runtime-path) 9 | 10 | (define-runtime-path example.key "example.key") 11 | (define-runtime-path example.crt "example.crt") 12 | 13 | (define (pp-message m) 14 | (define (help v) 15 | (cond 16 | [(message? v) 17 | `((fields . ,(message-fields v)) 18 | (entity . ,(help (message-entity v))))] 19 | 20 | [(entity? v) 21 | `((type . ,(entity-type v)) 22 | (subtype . ,(entity-subtype v)) 23 | (fields . ,(entity-fields v)) 24 | (parts . ,(map help (entity-parts v))) 25 | (body . ,(and 26 | (not (null? (entity-body v))) 27 | (call-with-output-bytes (entity-body v)))))] 28 | 29 | [else 30 | (raise-argument-error 'pp-message "(or/c message? entity?)" v)])) 31 | (pretty-print (help m))) 32 | 33 | (define ssl-context 34 | (ssl-make-server-context 35 | #:private-key `(pem ,example.key) 36 | #:certificate-chain example.crt)) 37 | 38 | (define stop 39 | (start-smtp-server 40 | #:host "127.0.0.1" 41 | #:port 8675 42 | #:tls-encode (λ (in out 43 | #:mode mode 44 | #:encrypt protocol 45 | #:close-original? close?) 46 | (ports->ssl-ports 47 | in out 48 | #:mode mode 49 | #:context ssl-context 50 | #:encrypt protocol 51 | #:close-original? close?)) 52 | (λ (e) 53 | (println e) 54 | (pp-message (mime-analyze (envelope-data e)))))) 55 | 56 | (with-handlers ([exn:break? (λ (_) (stop))]) 57 | (sync never-evt)) 58 | -------------------------------------------------------------------------------- /smtp-server-test/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2021 Bogdan Popa 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are 5 | met: 6 | 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 14 | 3. Neither the name of the copyright holder nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /smtp-server-test/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define license 'BSD-3-Clause) 4 | (define collection "tests") 5 | (define deps '("base")) 6 | (define build-deps '("net-lib" 7 | "rackcheck-lib" 8 | "rackunit-lib" 9 | "smtp-server")) 10 | -------------------------------------------------------------------------------- /smtp-server-test/net/smtp-server-example.crt: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIIFazCCA1OgAwIBAgIUD4RnZj2EKBxAVGLiCB/Bkym6uBYwDQYJKoZIhvcNAQEL 3 | BQAwRTELMAkGA1UEBhMCQVUxEzARBgNVBAgMClNvbWUtU3RhdGUxITAfBgNVBAoM 4 | GEludGVybmV0IFdpZGdpdHMgUHR5IEx0ZDAeFw0yMTExMDEwOTMzMzhaFw0zMTEw 5 | MzAwOTMzMzhaMEUxCzAJBgNVBAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEw 6 | HwYDVQQKDBhJbnRlcm5ldCBXaWRnaXRzIFB0eSBMdGQwggIiMA0GCSqGSIb3DQEB 7 | AQUAA4ICDwAwggIKAoICAQDur3qZSUOTGAbg+q/10kmzC7UziwCo9g9e0/5XTw8v 8 | qRQZBU67pjInBqX7GYYthWRwsYamggmFqL9VRRSUATDbKHZRQJ6Sp617f/Ji/H3i 9 | im7Gcj/NTouxJB6Oubf6mR4wBfi1vTHmvKi5uTdOmHo7nySjxqL9iQDDTj2JzvRt 10 | BWs24JQozaiurE++h7a0fYtYhhGaDM7HPYNKGsWVreSbd31iRyc+0QITm6f78vlX 11 | KpnGvtNftp2IGYNjdl0xDEl/lfk2vWwfgayCxStwKnWIY9GdDqKBrj4qEqBL5IHY 12 | maaxWeFy6ggzVoUZ1uBQ/1jv/LtULn42xu6FB6wpJkGx11TROoUSa1sLVUcNk12a 13 | /zOdHH54PsIce2mFY3/2qWTy5jghRY2CqmUDiz/PmAdT10SGL4zd3BxMl50fHq+1 14 | 4cWGCH5PHU1V02/PgjDuGLZo7+728x18PkoWq56pWM9v6NW4X94ObK1wz7LCUPSX 15 | Y4+Q+Qf1wq5LEqpZZpyJxd4qG8krGSaVoLypkCCCZYk+NckJg1kRP1HB6uKZLi8f 16 | 4WQX3UJgXSeQjra81ee02quBs88ZMXianIfKOWRgKR+tfeg7tiiAC8aJ0UCXej+v 17 | UfNdrwqPJsCi3ZvzwabjMjUNh+7jmIJncaMVEqWRINY1bqjN3xHTffGpQcODNUJD 18 | 9wIDAQABo1MwUTAdBgNVHQ4EFgQUzFpiy4Ks5sOXrOrovnDsY06cob0wHwYDVR0j 19 | BBgwFoAUzFpiy4Ks5sOXrOrovnDsY06cob0wDwYDVR0TAQH/BAUwAwEB/zANBgkq 20 | hkiG9w0BAQsFAAOCAgEAuYqVeIsgNv1ragEm17Sf6Bc+Q/C4WvSUOFPjfKSN7hYU 21 | 5ELx+0Rnj8zYiPP2GyKsmwvFMrzRf0g5//RtavzMvhsZ2ewXFudJGk+jcSKL4YIM 22 | 8ifJ4EoK7ID22LYa6KPAoju1cu9NFbRjFSIzK2T+hFOiMNE43NTE+sw4eu+VPdwU 23 | rXsZ8B4KmZ8CxEaraVRzaCaMUN2cSoVOzyLvrY4MZ/+eDdEH7nnIPoC9L4VBitOt 24 | wxvThuxRT7zwV1sfb5SQBwwL4QVW00gDzHmB9sbZedueFef2oWOVTxktFC+3WXoh 25 | V3cax1UxtVlTjXVSFG8gFwNUyaFdY+OkBe6KDh3xFXHALDYkGa0uJLq8Wt8Styk+ 26 | +iOBXBghlVJszJyp0/lGoxwpeF6fd5kq5KGIwtwUjcuwQYNLcDIg3APx/2ONCMPH 27 | aXM9Ja2TtjtGWbouTZ54wX4bXJlGc0GNjzqGvKasYTQKYU1JWaJf4tsU+U7WYH0G 28 | zp7T2I+3pexV8OTzAg5FU8iIcrAlFPddnVFVZuEyYhC9G6E3DwjfDsfjZZfP2eXh 29 | ufp8393G/CciXcXQKsYcmPPikV0Yo4EQ/EgDsBlFl1LD+rBNa4GZqpJPJpUJG7f+ 30 | bdVFaoV9nucxmQWYp4HoS8RDtapThhBcgkunac+Bkx3RCH3AqGX9bat/QWiQwq8= 31 | -----END CERTIFICATE----- 32 | -------------------------------------------------------------------------------- /smtp-server-test/net/smtp-server-example.key: -------------------------------------------------------------------------------- 1 | -----BEGIN PRIVATE KEY----- 2 | MIIJQgIBADANBgkqhkiG9w0BAQEFAASCCSwwggkoAgEAAoICAQDur3qZSUOTGAbg 3 | +q/10kmzC7UziwCo9g9e0/5XTw8vqRQZBU67pjInBqX7GYYthWRwsYamggmFqL9V 4 | RRSUATDbKHZRQJ6Sp617f/Ji/H3iim7Gcj/NTouxJB6Oubf6mR4wBfi1vTHmvKi5 5 | uTdOmHo7nySjxqL9iQDDTj2JzvRtBWs24JQozaiurE++h7a0fYtYhhGaDM7HPYNK 6 | GsWVreSbd31iRyc+0QITm6f78vlXKpnGvtNftp2IGYNjdl0xDEl/lfk2vWwfgayC 7 | xStwKnWIY9GdDqKBrj4qEqBL5IHYmaaxWeFy6ggzVoUZ1uBQ/1jv/LtULn42xu6F 8 | B6wpJkGx11TROoUSa1sLVUcNk12a/zOdHH54PsIce2mFY3/2qWTy5jghRY2CqmUD 9 | iz/PmAdT10SGL4zd3BxMl50fHq+14cWGCH5PHU1V02/PgjDuGLZo7+728x18PkoW 10 | q56pWM9v6NW4X94ObK1wz7LCUPSXY4+Q+Qf1wq5LEqpZZpyJxd4qG8krGSaVoLyp 11 | kCCCZYk+NckJg1kRP1HB6uKZLi8f4WQX3UJgXSeQjra81ee02quBs88ZMXianIfK 12 | OWRgKR+tfeg7tiiAC8aJ0UCXej+vUfNdrwqPJsCi3ZvzwabjMjUNh+7jmIJncaMV 13 | EqWRINY1bqjN3xHTffGpQcODNUJD9wIDAQABAoICAAo2T9SHIfEFMiYmE6k82hJj 14 | CdmutNSF0pqID3XE2C192nJHm9rDfZnV2vwnV2pTLrzzm4M8RRQG6EjJr9u1QVXf 15 | IVDQpvg3XGDQVJqPmwM6UQsEkF5EYg2uMfCBWbHLI1OCreV4ts3cfIuVtRwTwgcT 16 | BApN0WNvnSy+CDwBMswHU1MBwNUOF42BqdfJDrQiOvgKpG4m5iH4K8nb42BIFGPi 17 | dObjjHZPkvsrycAp4SktlW6/c2PA+HR+QvTad5pFoE9pJ0SETj/62Fqv/O/LoUO4 18 | oZtKqQFLZzV9noYgvL17tXoZEmBMSxWHOiKk4uwUQMXj1k//vT6yvDnM3jzUejMA 19 | jT28Hm14Eaakqg49S6TeEi9mb9OeygNHDkdOfRF4eVXAyIKt63+9R/BoF97TzlUf 20 | ZnOHQ+k61TPObb/OaSeijrzNZcNL71a2SJxQuqx8TiBWVoTA5XoqK1iibpw4fwHB 21 | Ybj0T4b0c6t77M1zfHo3EnC9BR2fbYpCSxnJVH8p+iyNDfVfwXIqZo1+zPPQiR27 22 | DB/XjO+8t0wgqLsyLLaaEBomR/tU40vo7o4dX1BeInypZpm+w2RLxslK/aton1qK 23 | hyHW6f3KrWtP3DYt/Bk8Coh3WeePjNBf0uRmlrK/hCr9CzIyXSzwylr9x6P+nNiv 24 | +8W2DwgraiETMnVZF3BBAoIBAQD/8K15Tm5ND1WkpDpEeZJb3jBKodmBSH20WjEy 25 | phVcdsETfR132GFbz13IoA6PYgl9tReyMGcg9+Y+RVzNjNlEPMsmdyILzMPL9fbN 26 | K5cM57TdLmYXvfU6ZXs5e0F0EPkbJdEIbHx6aKI0o6CmR6zFa9aHnAWWkdoQhmfh 27 | T4w8q0LplLIf0WezXGleygrXj/E/xu7K+3g+l0lg3hhRvzRfHIba3RgSYJlS7dCC 28 | xN963MqGrGgYNr9yIreg+Bofja/XHGw/tKGFjuNIuUhIhw10ga84LuCqpPtmSVJO 29 | z36+PKkkgcYp4ECiXJrBWTxiWQ0Zmg6STR9/r6tUcdqGsHqPAoIBAQDuvcSuNWaJ 30 | viHw2JvbruIi31VkAmmMY+KbGD41kHrn4ZMi3cHY1GKa8G0nBtY+lpkSwHcY/AH7 31 | 7KZKl9QyX0wGfjKnXO7Uo8CgMDSdAqw6rccFWDQmw60HCrJKZrlpvp+raBzW2hUN 32 | ayh65V+5G2ocb7SmNI2FS2Wz3XQ4Zt+6vi0EsSWNtWoysm233s9uHfppmts000E0 33 | rIQ6sUCv5FhysdFuTE1TTUimj6zJsXcFtaCLbCxow/NYIK8Zy7wmiJJ6dH7u+0qP 34 | a1OEjg/QvLh+g+USNrbAXWVO2nY4finR7HowdwtlMhnZMyR8Jo3fpQcGIlAdObn6 35 | ZV7yeWpGavQZAoIBAQDhvJqUkouQpgTImRzXRk7Dfl4jhUr8zz4n8yDPZlMS4Z77 36 | nG+AQ7XjLyuthxYweqyaVj4XKL/dASjvJWhr113N5LzdKVg7BhhvbXqHjXnFpRwN 37 | tR3QtPd00Qr1MPQS9eFwg1Mx1dWYdW8TdHp+DluhKLLnmsIHAo9N4e3/eJTc8cSr 38 | lj3g+GY5eTlqpFMZu1hyAvicyV1N/0t2B411lGoRtWxv32+azd6NmTk+DXx6tgBe 39 | 9fM94BPNDDff3tPTnrlHxkbnjV6lGNj4TIsnhQ5mAvfTWu1HNQqTNfpFjpdgHMqm 40 | a1unlaYMThckj5tFtvtp6EoP2bv9d6hqa5ztDPybAoIBAGO1V+5WGSQQB4baQIXI 41 | jWN5GOWy6DgdA2g5AMpINDyiBlx6d1pCoYgKP9wby+DJ7tZZEaSao41+sZjXvmTn 42 | Tg4sKKWjd4/RcEK2v1KP6jR7nXJK+0TxVlNpkTrnmipi1ba1vc2xuTcoePiS0Z6y 43 | p2eG89CyhCSWb7xmEgL4XBpXEOAzx/ZePSM9R/uSD9nypUHzzfdK/6GrJ3KH0vdj 44 | C9mjEE/biDPxRBVkTgrSll4JFCsGm6mJpRk6VUcVwtfpFBwWiWjwBJzPe0sSNeK8 45 | 3uTf2wz3Uu4WU5hSPyuq7XZiKEoTfevet9LxvBwp0fkEqGFUdVcvY9ADBFuKf+s3 46 | AgkCggEAIGPPp1Vc9FoqCZMTsTcTC8IkU/H0UuCbKT2OTPVul1JwgLJCKi1OlF0p 47 | y5PTndE/SDKQqQmIa/sC5oA3v+gEePj7dn33LJ6u8EVD3ekqMYk+MVkJ8gcodRTc 48 | yv2JYptMRKiDDrqZO8WSXS7RGj3HJbX7/i/llEyW7b5xGJ4WR/7iEWTvQKt3hPjU 49 | 0xK4mw8DCvM0kJiMEwCBHk8o7/xM71GN8bQDqaxl5gwLbJIhAHuRu8U4savWgPsn 50 | jFkIW5IfUcAGgZCcJJOPIPwln44pmusVWU4gHBANsIextCxa69FyGYFuSAwk98rO 51 | pd107qK/Yyol+1zhHIeNSWBer4ZWhw== 52 | -----END PRIVATE KEY----- 53 | -------------------------------------------------------------------------------- /smtp-server-test/net/smtp-server.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require net/smtp 4 | net/smtp-server 5 | (submod net/smtp-server private) 6 | openssl 7 | rackcheck 8 | racket/runtime-path 9 | rackunit) 10 | 11 | (define-runtime-path key-path "smtp-server-example.key") 12 | (define-runtime-path cert-path "smtp-server-example.crt") 13 | 14 | (define (gen:smtp-line max-len) 15 | (gen:let ([content (gen:bytes #:max-length (- max-len 2))]) 16 | (bytes-append (regexp-replace* #rx#"\r\n" content #"\r\x00") #"\r\n"))) 17 | 18 | (define all-tests 19 | (test-suite 20 | "smtp-server" 21 | 22 | (test-suite 23 | "reading" 24 | 25 | (test-suite 26 | "read-smtp-line!" 27 | 28 | (check-property 29 | (property ([max-len (gen:integer-in 2 100)] 30 | [buf-len (gen:choice 31 | (gen:const 1) 32 | (gen:integer-in 1 128))] 33 | [line (gen:smtp-line max-len)]) 34 | (define line-buf (make-bytes max-len)) 35 | (define scratch-buf (make-bytes buf-len)) 36 | (define line-len 37 | (read-smtp-line! line-buf (open-input-bytes line) scratch-buf)) 38 | (check-equal? line (subbytes line-buf 0 line-len))))) 39 | 40 | (test-suite 41 | "discard-smtp-line" 42 | 43 | (check-property 44 | (property ([max-len (gen:integer-in 2 100)] 45 | [buf-len (gen:choice 46 | (gen:const 1) 47 | (gen:integer-in 1 128))] 48 | [line (gen:smtp-line max-len)]) 49 | (define scratch-buf (make-bytes buf-len)) 50 | (define discarded-len 51 | (discard-smtp-line (open-input-bytes line) scratch-buf)) 52 | (check-equal? (bytes-length line) discarded-len))))) 53 | 54 | (let ([stop #f] [envelopes null]) 55 | (test-suite 56 | "end-to-end" 57 | 58 | #:before 59 | (λ () 60 | (define ssl-context 61 | (ssl-make-server-context 62 | #:private-key `(pem ,key-path) 63 | #:certificate-chain cert-path)) 64 | 65 | (set! stop (start-smtp-server 66 | #:port 10025 67 | #:tls-encode (λ (in out #:mode mode #:encrypt protocol #:close-original? close?) 68 | (ports->ssl-ports 69 | in out 70 | #:mode mode 71 | #:context ssl-context 72 | #:encrypt protocol 73 | #:close-original? close?)) 74 | (λ (envelope) 75 | (set! envelopes (cons envelope envelopes)))))) 76 | 77 | #:after 78 | (λ () 79 | (and stop (stop))) 80 | 81 | (test-case "receiving an e-mail in plain text" 82 | (smtp-send-message 83 | #:port-no 10025 84 | "127.0.0.1" 85 | "bogdan@defn.io" 86 | '("bogdan@example.com") 87 | "Subject: hi\r\n" 88 | (list "Hello!")) 89 | (check-equal? 90 | envelopes 91 | (list 92 | (envelope 93 | #"bogdan@defn.io" 94 | '(#"bogdan@example.com") 95 | #"Subject: hi\r\nHello!\r\n")))) 96 | 97 | ;; Disable test case under GHA due to OpenSSL fuckery. 98 | (unless (getenv "GITHUB_ACTIONS") 99 | (test-case "receiving an e-mail via STARTTLS" 100 | (set! envelopes null) 101 | (smtp-send-message 102 | #:port-no 10025 103 | #:tls-encode ports->ssl-ports 104 | "127.0.0.1" 105 | "bogdan@defn.io" 106 | '("bogdan@example.com" "paul@example.com") 107 | "Subject: hi\r\n" 108 | (list "Hello!")) 109 | (check-equal? 110 | envelopes 111 | (list 112 | (envelope 113 | #"bogdan@defn.io" 114 | '(#"paul@example.com" #"bogdan@example.com") 115 | #"Subject: hi\r\nHello!\r\n"))))))))) 116 | 117 | 118 | (module+ test 119 | (require rackunit/text-ui) 120 | (run-tests all-tests)) 121 | -------------------------------------------------------------------------------- /smtp-server/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2021 Bogdan Popa 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are 5 | met: 6 | 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 14 | 3. Neither the name of the copyright holder nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /smtp-server/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define license 'BSD-3-Clause) 4 | (define version "0.1") 5 | (define collection "net") 6 | (define deps '("base")) 7 | (define build-deps '("racket-doc" 8 | "scribble-lib")) 9 | (define scribblings '(("scribblings/smtp-server.scrbl" () (net-library)))) 10 | -------------------------------------------------------------------------------- /smtp-server/scribblings/smtp-server.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label net/smtp-server 4 | openssl 5 | racket/base 6 | racket/contract 7 | racket/string 8 | racket/os)) 9 | 10 | @title{SMTP Server} 11 | @author[(author+email "Bogdan Popa" "bogdan@defn.io")] 12 | @defmodule[net/smtp-server] 13 | 14 | This module module provides a minimal implementation of RFC 5321 15 | @cite{RFC5321} that can receive e-mail messages. 16 | 17 | @section{Usage} 18 | 19 | @racketblock[ 20 | (define stop 21 | (start-smtp-server println)) 22 | ] 23 | 24 | The example above starts an SMTP server on @tt{localhost} port 25 | @racket[25] that prints all incoming e-mail to standard out. Calling 26 | the @racket[stop] function terminates any connections in flight and 27 | stops the server. 28 | 29 | @(define repo-link 30 | (link "https://github.com/Bogdanp/racket-smtp-server" "source code repository")) 31 | 32 | See "example/" in the @repo-link for an example with @tt{STARTTLS} support. 33 | 34 | 35 | @section{Reference} 36 | 37 | @defthing[tls-encode-proc/c (-> input-port? 38 | output-port? 39 | #:mode 'tcp 40 | #:encrypt 'tls 41 | #:close-original? #t 42 | (values input-port? output-port?))]{ 43 | 44 | The contract for TLS-encoding procedures. See also 45 | @racket[ports->ssl-ports]. 46 | } 47 | 48 | @defparam[current-smtp-hostname hostname non-empty-string? #:value (gethostname)]{ 49 | Controls the host name displayed to clients. 50 | } 51 | 52 | @defstruct[envelope ([sender bytes?] 53 | [recipients (listof bytes?)] 54 | [data bytes?])]{ 55 | 56 | Represents the sender, recipients and contents of a receieved e-mail. 57 | } 58 | 59 | @defproc[(start-smtp-server [handler (-> envelope? void?)] 60 | [#:host host string? "127.0.0.1"] 61 | [#:port port (integer-in 0 65535) 25] 62 | [#:limits lim smtp-limits? (make-smtp-limits)] 63 | [#:tls-encode tls-encode (or/c #f tls-encode-proc/c) #f]) (-> void?)]{ 64 | 65 | Starts an SMTP server that listens on @racket[host] and 66 | @racket[port] and returns a function that will stop the server when 67 | applied. 68 | 69 | Successfully-received e-mails are passed to @racket[handler]. When 70 | the @racket[handler] raises an exception, the server notifies the 71 | client that the message has been rejected. 72 | 73 | The @racket[#:limits] arguments can be used to customize various 74 | @tech{security limits}. 75 | 76 | If the optional @racket[#:tls-encode] argument supplies a 77 | @racket[tls-encode-proc/c] value, the server advertises 78 | @tt{STARTTLS} support and clients may opt in to TLS encryption. 79 | } 80 | 81 | @deftogether[( 82 | @defproc[(smtp-limits? [v any/c]) boolean?] 83 | @defproc[(make-smtp-limits [#:max-connections max-connections exact-positive-integer? 512] 84 | [#:max-line-length max-line-length exact-nonnegative-integer? 1024] 85 | [#:max-envelope-length max-envelope-length exact-nonnegative-integer? (* 10 1024 1024)] 86 | [#:session-timeout session-timeout (and/c number? positive?) 300]) smtp-limits?] 87 | )]{ 88 | @deftech{Security limits} allow you to configure various 89 | security-related limits on an SMTP server. 90 | 91 | The @racket[#:max-connections] argument controls the maximum number 92 | of concurrent client connections that the server will accept at a 93 | time. 94 | 95 | The @racket[#:max-line-length] argument controls the maximum length 96 | in bytes of each line received from a client may be. The server 97 | will reject lines longer than this amount. 98 | 99 | The @racket[#:max-envelope-length] argument controls the maximum 100 | length of incoming e-mails from clients. The total length of an 101 | envlope includes the length in bytes of the sender and the 102 | recipients list as well as the message data. 103 | 104 | The @racket[#:session-timeout] argument controls the maximum amount 105 | of time, in seconds, that a client session may be open for. 106 | } 107 | 108 | 109 | @bibliography[ 110 | @bib-entry[ 111 | #:key "RFC5321" 112 | #:title "Simple Mail Transfer Protocol" 113 | #:author "J. Klensin" 114 | #:date "2008" 115 | #:url "https://www.ietf.org/rfc/rfc5321.html" 116 | ] 117 | ] 118 | -------------------------------------------------------------------------------- /smtp-server/smtp-server.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract 4 | racket/format 5 | racket/os 6 | racket/string 7 | racket/tcp) 8 | 9 | ;; params ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (provide 12 | (contract-out 13 | [current-smtp-hostname (parameter/c non-empty-string?)])) 14 | 15 | (define current-smtp-hostname 16 | (make-parameter (gethostname))) 17 | 18 | 19 | ;; limits ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 20 | 21 | (provide 22 | smtp-limits? 23 | (contract-out 24 | [make-smtp-limits (->* () 25 | (#:max-connections exact-positive-integer? 26 | #:max-line-length exact-nonnegative-integer? 27 | #:max-envelope-length exact-nonnegative-integer? 28 | #:session-timeout (and/c number? positive?)) 29 | smtp-limits?)])) 30 | 31 | (struct smtp-limits 32 | (max-connections 33 | max-line-length 34 | max-envelope-length 35 | session-timeout) 36 | #:transparent) 37 | 38 | (define (make-smtp-limits #:max-connections [max-connections 512] 39 | #:max-line-length [max-line-length 1024] 40 | #:max-envelope-length [max-envelope-length (* 10 1024 1024)] 41 | #:session-timeout [session-timeout 300]) 42 | (smtp-limits max-connections max-line-length max-envelope-length session-timeout)) 43 | 44 | (define (make-session-deadline lim) 45 | (alarm-evt (+ (current-inexact-milliseconds) 46 | (* (smtp-limits-session-timeout lim) 1000.0)))) 47 | 48 | (define (max-connections? lim n) 49 | (>= n (smtp-limits-max-connections lim))) 50 | 51 | 52 | ;; envelope ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 53 | 54 | (provide 55 | (contract-out 56 | (struct envelope 57 | ([sender bytes?] 58 | [recipients (listof bytes?)] 59 | [data bytes?])))) 60 | 61 | (struct envelope (sender recipients data) 62 | #:transparent) 63 | 64 | (define (make-envelope sender) 65 | (envelope sender null #"")) 66 | 67 | (define (add-envelope-recipient e rcpt) 68 | (struct-copy envelope e [recipients (cons rcpt (envelope-recipients e))])) 69 | 70 | (define (add-envelope-data e data) 71 | (struct-copy envelope e [data data])) 72 | 73 | (define (envelope-length e) 74 | (+ (bytes-length (envelope-data e)) 75 | (bytes-length (envelope-sender e)) 76 | (for/sum ([r (in-list (envelope-recipients e))]) 77 | (bytes-length r)))) 78 | 79 | (define (envelope-too-long? e lim) 80 | (> (envelope-length e) 81 | (smtp-limits-max-envelope-length lim))) 82 | 83 | 84 | ;; server ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 85 | 86 | (provide 87 | tls-encode-proc/c 88 | (contract-out 89 | [start-smtp-server (->* ((-> envelope? void?)) 90 | (#:host string? 91 | #:port (integer-in 0 65535) 92 | #:limits smtp-limits? 93 | #:tls-encode (or/c #f tls-encode-proc/c)) 94 | (-> void?))])) 95 | 96 | (define-logger smtp-server) 97 | 98 | (define tls-encode-proc/c 99 | (-> input-port? 100 | output-port? 101 | #:mode 'accept 102 | #:encrypt 'tls 103 | #:close-original? #t 104 | (values input-port? output-port?))) 105 | 106 | (define (start-smtp-server handler 107 | #:host [host "127.0.0.1"] 108 | #:port [port 25] 109 | #:limits [lim (make-smtp-limits)] 110 | #:tls-encode [tls-encode #f]) 111 | (define cust (make-custodian)) 112 | (define stop-ch (make-channel)) 113 | (define server-thd 114 | (parameterize ([current-custodian cust]) 115 | (define listener 116 | (tcp-listen port 128 #t host)) 117 | (thread 118 | (lambda () 119 | (let loop ([deadlines (hasheq)]) 120 | (apply 121 | sync 122 | (handle-evt stop-ch void) 123 | (handle-evt 124 | (if (max-connections? lim (hash-count deadlines)) never-evt listener) 125 | (lambda (_) 126 | (define-values (in out) 127 | (tcp-accept listener)) 128 | (define-values (_local-ip remote-ip) 129 | (tcp-addresses in)) 130 | (define connection-id 131 | (string->symbol (~a "conn:" remote-ip))) 132 | (define client-thd 133 | (thread 134 | (procedure-rename 135 | (lambda () 136 | (client-loop in out lim handler tls-encode)) 137 | connection-id))) 138 | (log-smtp-server-debug "accepted connection ~a" client-thd) 139 | (loop (hash-set deadlines client-thd (make-session-deadline lim))))) 140 | (append 141 | (for/list ([client-thd (in-hash-keys deadlines)]) 142 | (handle-evt 143 | client-thd 144 | (lambda (_) 145 | (log-smtp-server-debug "connection ~a closed" client-thd) 146 | (loop (hash-remove deadlines client-thd))))) 147 | (for/list ([(client-thd deadline-evt) (in-hash deadlines)]) 148 | (handle-evt 149 | deadline-evt 150 | (lambda (_) 151 | (break-thread client-thd 'hang-up) 152 | (log-smtp-server-warning "~a session timed out" client-thd) 153 | (loop (hash-remove deadlines client-thd)))))))))))) 154 | (lambda () 155 | (channel-put stop-ch #t) 156 | (thread-wait server-thd) 157 | (custodian-shutdown-all cust))) 158 | 159 | (define (client-loop in out lim handler tls-encode) 160 | (define hostname (current-smtp-hostname)) 161 | (define line-buf (make-bytes (smtp-limits-max-line-length lim))) 162 | (define scratch-buf (make-bytes (smtp-limits-max-line-length lim))) 163 | (let connection-loop ([in in] 164 | [out out] 165 | [start? #t]) 166 | (define (rep- status message) 167 | (fprintf out "~a-~a\r\n" status message)) 168 | (define (rep status [message "OK"]) 169 | (fprintf out "~a ~a\r\n" status message) 170 | (flush-output out)) 171 | (when start? 172 | (rep 220 hostname)) 173 | (with-handlers ([exn:break:hang-up? void] 174 | [exn:fail? (λ (e) (log-smtp-server-warning "unhandled error: ~a" (exn-message e)))]) 175 | (let loop ([envelope #f]) 176 | (define line-len (read-smtp-line! line-buf in scratch-buf)) 177 | (case (and line-len (parse-command line-buf line-len)) 178 | [(#f) 179 | (discard-smtp-line in scratch-buf) 180 | (rep 500 "line too long") 181 | (loop #f)] 182 | 183 | [(#"HELO") 184 | (rep 250) 185 | (loop #f)] 186 | 187 | [(#"EHLO") 188 | (rep- 250 hostname) 189 | (rep- 250 "8BITMIME") 190 | (rep- 250 (format "SIZE ~a" (smtp-limits-max-envelope-length lim))) 191 | (when tls-encode 192 | (rep- 250 "STARTTLS")) 193 | (rep 250) 194 | (loop #f)] 195 | 196 | [(#"RSET") 197 | (rep 250) 198 | (loop #f)] 199 | 200 | [(#"NOOP") 201 | (rep 250) 202 | (loop envelope)] 203 | 204 | [(#"STARTTLS") 205 | (with-handlers ([exn:fail? (λ (_) 206 | (log-smtp-server-warning "TLS handshake failed") 207 | (rep 500 "protocol error") 208 | (loop #f))]) 209 | (rep 220) 210 | (log-smtp-server-debug "initiating TLS handshake") 211 | (define-values (ssl-in ssl-out) 212 | (tls-encode in out #:mode 'accept #:encrypt 'tls #:close-original? #t)) 213 | (log-smtp-server-debug "TLS connection initiatied") 214 | (connection-loop ssl-in ssl-out #f))] 215 | 216 | [(#"MAIL") 217 | ;; Potential improvements: 218 | ;; * Handling of 7BIT or 8BITMIME params from RFC1652 219 | ;; * Handling of SIZE= param from RFC1870 220 | (cond 221 | [envelope 222 | (rep 503 "nested MAIL command") 223 | (loop envelope)] 224 | 225 | [(regexp-match #rx#"^(?i:(mail from:<(.+)>))" line-buf 0 line-len) 226 | => (λ (matches) 227 | (define new-envelope 228 | (make-envelope (caddr matches))) 229 | (cond 230 | [(envelope-too-long? new-envelope lim) 231 | (rep 552 "message exceeds fixed message maximum size") 232 | (loop #f)] 233 | 234 | [else 235 | (rep 250) 236 | (loop (make-envelope (caddr matches)))]))] 237 | 238 | [else 239 | (rep 501 "syntax: MAIL FROM:
") 240 | (loop #f)])] 241 | 242 | [(#"RCPT") 243 | (cond 244 | [(and envelope (regexp-match #rx#"^(?i:(rcpt to:<(.+)>))" line-buf 0 line-len)) 245 | => (λ (matches) 246 | (define new-envelope 247 | (add-envelope-recipient envelope (caddr matches))) 248 | (cond 249 | [(envelope-too-long? new-envelope lim) 250 | (rep 552 "message exceeds fixed message maximum size") 251 | (loop envelope)] 252 | 253 | [else 254 | (rep 250) 255 | (loop new-envelope)]))] 256 | 257 | [envelope 258 | (rep 501 "syntax: RCPT TO:
") 259 | (loop envelope)] 260 | 261 | [else 262 | (rep 503 "need MAIL command") 263 | (loop #f)])] 264 | 265 | [(#"DATA") 266 | (cond 267 | [(and envelope (null? (envelope-recipients envelope))) 268 | (rep 503 "need recipients") 269 | (loop envelope)] 270 | 271 | [envelope 272 | (rep 354 "end data with .") 273 | (define max-len 274 | (- (smtp-limits-max-envelope-length lim) 275 | (envelope-length envelope))) 276 | (define data 277 | (read-mail-data line-buf in scratch-buf max-len)) 278 | (cond 279 | [data 280 | (with-handlers ([exn:fail? 281 | (λ (e) 282 | (log-smtp-server-warning "unexpected handler error: ~a" (exn-message e)) 283 | (rep 554 "internal error"))]) 284 | (handler (add-envelope-data envelope data)) 285 | (rep 250)) 286 | (loop #f)] 287 | 288 | [else 289 | (rep 552 "message exceeds fixed message maximum size") 290 | (loop envelope)])] 291 | 292 | [else 293 | (rep 503 "need MAIL command") 294 | (loop #f)])] 295 | 296 | [(#"QUIT") 297 | (rep 221 "goodbye")] 298 | 299 | [else 300 | (rep 502 "command not recognized") 301 | (loop envelope)]))) 302 | (parameterize-break #f 303 | (close-output-port out) 304 | (close-input-port in)))) 305 | 306 | (define (parse-command line [len (bytes-length line)]) 307 | (define end 308 | (or (find-sp line len) 309 | (find-crlf line len) 310 | len)) 311 | (define bs (subbytes line 0 end)) 312 | (begin0 bs 313 | (bytes-upcase! bs))) 314 | 315 | (define (bytes-upcase! bs) 316 | (for ([i (in-naturals)] 317 | [b (in-bytes bs)] 318 | #:when (and (>= b 97) 319 | (<= b 122))) 320 | (bytes-set! bs i (- b 32)))) 321 | 322 | 323 | ;; reading ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 324 | 325 | ;; The reading functions each try to read data with minimal allocations 326 | ;; and buffering. They assume that the other end is adversarial. 327 | 328 | (module+ private 329 | (provide 330 | read-mail-data 331 | read-smtp-line! 332 | discard-smtp-line)) 333 | 334 | ;; Reads mail DATA line-by-line until a #".\x0D\x0A" line. If the 335 | ;; length of the data exceeds `max-len' or if any of the lines exceeds 336 | ;; the current max line length, it discards all the lines up to and 337 | ;; including terminator line and returns `#f'. 338 | (define (read-mail-data line-buf in buf max-len) 339 | (let loop ([data-len 0] 340 | [lines null] 341 | [failed? #f]) 342 | (define line-len 343 | (read-smtp-line! line-buf in buf)) 344 | (define next-len 345 | (and line-len (+ data-len line-len))) 346 | (cond 347 | [(not line-len) 348 | (loop (+ data-len (discard-smtp-line in buf)) null #t)] 349 | 350 | [(zero? line-len) 351 | #f] 352 | 353 | [(terminator? line-buf line-len) 354 | (and (not failed?) 355 | (apply bytes-append (reverse lines)))] 356 | 357 | [(<= next-len max-len) 358 | (loop next-len (cons (subbytes line-buf 0 line-len) lines) failed?)] 359 | 360 | [else 361 | (loop next-len null #t)]))) 362 | 363 | ;; Reads a CRLF-terminated line from `in' into `bs'. Returns `#f' if 364 | ;; the line is longer than `bs', and the number of bytes read 365 | ;; otherwise. 366 | (define (read-smtp-line! bs in [buf (make-bytes 4096)]) 367 | (define len (bytes-length bs)) 368 | (let loop ([start 0] [pending-lf? #f]) 369 | (define n-peeked 370 | (peek-bytes-avail! buf 0 #f in)) 371 | (cond 372 | [(eof-object? n-peeked) 373 | start] 374 | 375 | [(and pending-lf? (lf? (bytes-ref buf 0))) 376 | (+ start (read-bytes! bs in start (add1 start)))] 377 | 378 | [(find-crlf buf n-peeked) 379 | => (λ (crlf-pos) 380 | (define end 381 | (+ start crlf-pos 2)) 382 | (and (<= end len) 383 | (+ start (read-bytes! bs in start end))))] 384 | 385 | [else 386 | (define end 387 | (+ start n-peeked)) 388 | (and (<= end (sub1 len)) 389 | (loop (+ start (read-bytes! bs in start end)) 390 | (cr? (bytes-ref buf (sub1 n-peeked)))))]))) 391 | 392 | ;; Discards all data from `in' up to the next CRLF or EOF. Returns 393 | ;; the number of discarded bytes. 394 | (define (discard-smtp-line in [buf (make-bytes 4096)]) 395 | (let loop ([n-discarded 0] 396 | [pending-lf? #f]) 397 | (define n-peeked 398 | (peek-bytes-avail! buf 0 #f in)) 399 | (cond 400 | [(eof-object? n-peeked) 401 | n-discarded] 402 | 403 | [(and pending-lf? (lf? (bytes-ref buf 0))) 404 | (+ n-discarded (read-bytes! buf in 0 1))] 405 | 406 | [(find-crlf buf n-peeked) 407 | => (λ (pos) 408 | (+ n-discarded (read-bytes! buf in 0 (+ pos 2))))] 409 | 410 | [else 411 | (define pending? (cr? (bytes-ref buf (sub1 n-peeked)))) 412 | (loop (+ n-discarded (read-bytes! buf in 0 n-peeked)) pending?)]))) 413 | 414 | (define (find-sp bs [stop (bytes-length bs)]) 415 | (for/first ([p (in-naturals)] 416 | [b (in-bytes bs 0 stop)] 417 | #:when (sp? b)) 418 | p)) 419 | 420 | (define (find-crlf bs [stop (bytes-length bs)]) 421 | (and (not (zero? stop)) 422 | (for/first ([p (in-naturals)] 423 | [b-cr (in-bytes bs 0 stop)] 424 | [b-lf (in-bytes bs 1 stop)] 425 | #:when (and (cr? b-cr) 426 | (lf? b-lf))) 427 | p))) 428 | 429 | (define (sp? b) (= b #x20)) 430 | (define (cr? b) (= b #x0D)) 431 | (define (lf? b) (= b #x0A)) 432 | (define (dot? b) (= b #x2E)) 433 | 434 | (define (terminator? bs len) 435 | (and (= len 3) 436 | (dot? (bytes-ref bs 0)) 437 | (cr? (bytes-ref bs 1)) 438 | (lf? (bytes-ref bs 2)))) 439 | --------------------------------------------------------------------------------