12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445 |
- ;; sudo guix system -L ../guix-packages/ reconfigure sway.scm
- ;; use the above to test this code on an actual system.
- (define-module (gnu services opensmtpd)
- #:use-module (gnu services)
- #:use-module (gnu services base)
- #:use-module (gnu services configuration)
- #:use-module (gnu services shepherd)
- #:use-module (gnu system pam)
- #:use-module (gnu system shadow)
- #:use-module (gnu packages mail)
- #:use-module (gnu packages admin)
- #:use-module (gnu packages dav)
- #:use-module (gnu packages tls)
- #:use-module (guix records)
- #:use-module (guix packages)
- #:use-module (guix gexp)
- #:use-module (ice-9 match)
- #:use-module (ice-9 format)
- #:use-module (srfi srfi-1)
- #:export (opensmtpd-service-type
- opensmtpd-table
- opensmtpd-table?
- opensmtpd-table-name
- opensmtpd-table-file
- opensmtpd-table-file-db
- opensmtpd-table-values
- opensmtpd-ca
- opensmtpd-ca?
- opensmtpd-name
- opensmtpd-file
- opensmtpd-pki
- opensmtpd-pki?
- opensmtpd-pki-domain
- opensmtpd-pki-cert
- opensmtpd-pki-key
- opensmtpd-local-delivery-configuration
- opensmtpd-local-delivery-configuration?
- opensmtpd-local-delivery-configuration-method
- opensmtpd-local-delivery-configuration-alias
- opensmtpd-local-delivery-configuration-ttl
- opensmtpd-local-delivery-configuration-user
- opensmtpd-local-delivery-configuration-userbase
- opensmtpd-local-delivery-configuration-virtual
- opensmtpd-local-delivery-configuration-wrapper
- openmstpd-relay-configuration
- opensmtpd-relay-configuration?
- openmstpd-relay-configuration-backup
- openmstpd-relay-configuration-helo
- openmstpd-relay-configuration-domain
- openmstpd-relay-configuration-host
- openmstpd-relay-configuration-pki
- openmstpd-relay-configuration-srs
- openmstpd-relay-configuration-tls
- openmstpd-relay-configuration-protocols
- openmstpd-relay-configuration-ciphers
- openmstpd-relay-configuration-auth
- openmstpd-relay-configuration-mail
- openmstpd-relay-configuration-src
- opensmtpd-action
- opensmtpd-action?
- opensmtpd-action-name
- opensmtpd-action-method
- opensmtpd-filter-chain
- opensmtpd-filter-chain?
- opensmtpd-filter-chain-name
- opensmtpd-filter-chain-filter-names
- opensmtpd-filter-phase
- opensmtpd-filter-phase?
- opensmtpd-filter-phase-name
- opensmtpd-filter-phase-phase-name
- opensmtpd-filter-phase-conditions
- opensmtpd-filter-phase-decision
- opensmtpd-filter-phase-message
- opensmtpd-filter-phase-value
-
- opensmtpd-filter-proc
- opensmtpd-filter-proc?
- opensmtpd-filter-proc-name
- opensmtpd-filter-proc-command
- opensmtpd-filter-proc-exec
- opensmtpd-filter-proc-exec?
- opensmtpd-filter-proc-exec-name
- opensmtpd-filter-proc-exec-command
- opensmtpd-listen-on
- opensmtpd-listen-on?
- opensmtpd-listen-on-interface
- opensmtpd-listen-on-auth
- opensmtpd-listen-on-auth-optional
- opensmtpd-listen-on-filter
- opensmtpd-listen-on-hostname
- opensmtpd-listen-on-hostnames
- opensmtpd-listen-on-mask-src
- opensmtpd-listen-on-no-dsn
- opensmtpd-listen-on-pki
- opensmtpd-listen-on-port
- opensmtpd-listen-on-proxy-v2
- opensmtpd-listen-on-received-auth
- opensmtpd-listen-on-senders
- opensmtpd-listen-on-secure-connection
- opensmtpd-listen-on-tag
- opensmtpd-listen-on-protocols
- opensmtpd-listen-on-ciphers
- opensmtpd-listen-on-socket
- opensmtpd-listen-on-socket?
- opensmtpd-listen-on-socket-filter
- opensmtpd-listen-on-socket-mask-src
- opensmtpd-listen-on-socket-tag
- opensmtpd-match
- opensmtpd-match?
- opensmtpd-match-name
- opensmtpd-match-for
- opensmtpd-match-from
- opensmtpd-match-auth
- opensmtpd-match-helo
- opensmtpd-match-mail-from
- opensmtpd-match-rcpt-to
- opensmtpd-match-tag
- opensmtpd-match-tls
- opensmtpd-proc
- opensmtpd-proc?
- opensmtpd-proc-name
- opensmtpd-proc-command
- opensmtpd-smtp-configuration
- opensmtpd-smtp-configuration?
- opensmtpd-smtp-configuration-ciphers
- opensmtpd-smtp-configuration-limit-max-mails
- opensmtpd-smtp-configuration-limit-max-rcpt
- opensmtpd-smtp-configuration-max-message-size
- opensmtpd-smtp-configuration-sub-addr-delim character
-
- opensmtpd-srs-configuration
- opensmtpd-srs-configuration?
- opensmtpd-srs-configuration-key
- opensmtpd-srs-configuration-key-backup
- opensmtpd-srs-configuration-ttl-delay
- opensmtpd-queue-configuration
- opensmtpd-queue-configuration?
- opensmtpd-queue-configuration-compression
- opensmtpd-queue-configuration-encryption
- opensmtpd-queue-configuration-ttl-delay
- opensmtpd-configuration
- opensmtpd-configuration?
- opensmtpd-package
- opensmtpd-config-file
- opensmtpd-configuration-actions
- opensmtpd-configuration-bounce
- opensmtpd-configuration-filter-chains
- opensmtpd-configuration-filter-phases
- opensmtpd-configuration-filter-procs
- opensmtpd-configuration-filter-proc-execs
- opensmtpd-configuration-listen-ons
- opensmtpd-configuration-listen-on-socket
- opensmtpd-configuration-includes
- opensmtpd-configuration-matches
- opensmtpd-configuration-mda-wrappers
- opensmtpd-configuration-pkis
- opensmtpd-configuration-procs
- opensmtpd-configuration-tables))
- ;; some fieldnames have a default value of #f, which is ok. They cannot have a value of #t.
- ;; for example opensmtpd-table-values can be #f, BUT NOT true.
- ;; my/sanitize procedure tests values to see if they are of the right kind.
- ;; procedure false? is needed to allow fields like 'values' to be blank, (empty), or #f BUT also
- ;; have a value like a list of strings.
- (define (false? value)
- (eq? #f value))
- (define (is-value-right-type? value list-of-procedures)
- (let loop ([list-of-procedures list-of-procedures])
- (if (null? list-of-procedures)
- #f
- (begin
- (if ((car list-of-procedures) value)
- #t
- (loop (cdr list-of-procedures)))))))
- ;; converts strings like this:
- ;; "apple, ham, cherry" -> "apple, ham, or cherry"
- ;; "pineapple" -> "pinneapple".
- ;; "cheese, grapefruit, or jam" -> "cheese, grapefruit, or jam"
- (define (add-comma-or string)
- (define last-comma-location (string-rindex string #\,))
- (if last-comma-location
- (if (string-contains string ", or" last-comma-location)
- string
- (string-replace string ", or" last-comma-location (+ 1 last-comma-location)))
- string))
- ;; FIXME/TODO combine this funcion with list-of-strings->string
- (define (strings->string list)
- (add-comma-or
- (string-append
- (string-drop-right
- (string-append "any of these strings: "
- (let loop ([list list])
- (if (null? list)
- ""
- (string-append
- (car list) ", "
- (loop (cdr list))))))
- 2)
- " ")))
- ;; I could test for read-ability of a file, but then I would have to
- ;; test the program as root everytime instead of as a normal user...
- (define (file-exists? file)
- (access? file F_OK))
- (define (list-of-procedures->string procedures)
- (define string
- (let loop ([procedures procedures])
- (if (null? procedures)
- ""
- (begin
- (string-append
- ;; FIXME/TODO add a guess function that takes a look at the
- ;; function... eg: list-of-opensmtpd-proc? -> "a list of
- ;; <opensmtpd-proc>s, "
- (cond [(eq? false? (car procedures))
- "#f , "]
- [(eq? boolean? (car procedures))
- "boolean, "]
- [(eq? string? (car procedures))
- "string, "]
- [(eq? integer? (car procedures))
- "integer, "]
- [(eq? list-of-strings? (car procedures))
- "list of strings, "]
- [(eq? assoc-list? (car procedures))
- "an association list, "]
- [(eq? file-exists? (car procedures))
- "file, "]
- [(eq? list-of-opensmtpd-filter-phase? (car procedures))
- "a list of <opensmtpd-filter-phase>s, "]
- [(eq? list-of-opensmtpd-filter-chain? (car procedures))
- "a list of <opensmtpd-filter-chain>s, "]
- [(eq? list-of-opensmtpd-proc? (car procedures))
- "a list of <opensmtpd-proc>s, "]
- [else
- (display "You've got some procedure that you don't know about.\n")
- (display (car procedures))
- (display "\n")
- (throw 'bad! (car procedures))])
- (loop (cdr procedures)))))))
- (add-comma-or (string-append (string-drop-right string 2) ".\n")))
- ;; TODO/FIXME? write a procedure (define (string-in-list? string
- ;; list)) The procedure will be used to sanitize the few values that
- ;; whose strings can be certain contrained
- ;; strings. opensmtpd-listen-on would use such a procedure.
- (define (my/sanitize value table fieldname list-of-procedures)
- (if (is-value-right-type? value list-of-procedures)
- value
- (begin
- (display (string-append "<" table "> fieldname: '" fieldname "' is of type "
- (list-of-procedures->string list-of-procedures) "\n"))
- (throw 'bad! value))))
- ;; FIXME/TODO? It is possible to create a table like this (opensmtpd-table (name "table")),
- ;; which is a table with no values or file, which is no table at all, and will result
- ;; in the service not starting. This is probably not worth fixing. Only silly users
- ;; would try to create a table with no values or file.
- (define-record-type* <opensmtpd-table>
- opensmtpd-table make-opensmtpd-table
- opensmtpd-table?
- this-record
- ;; string
- (name opensmtpd-table-name
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-table" "name" (list string?)))))
- (file opensmtpd-table-file
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-table" "file" (list false? string?)))))
- ;; is a list of values or key values
- ;; eg: (list "mysite.me" "your-site.com")
- ;; eg: (list ("joshua" . "joshua@gnu.org") ("james" . "james@gnu.org"))
- ;; I am currently making these values be as assocation list of strings only.
- ;; FIXME should I allow a value like this?
- ;; (list (cons "gnucode.me" 234.949.392.23))
- (file-db opensmtpd-table-file-db
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-table" "file-db" (list boolean?)))))
- ;; FIXME support an aliasing table as described here:
- ;; https://man.openbsd.org/table.5
- ;; One may have to use the record file for this. I don't think tables support a table like this:
- ;; table "name" { joshua = joshua@gnucode.me,joshua@gnu-hurd.com,joshua@propernaming.org, root = root@gnucode.me }
- (values opensmtpd-table-values
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-table" "values" (list false? list-of-strings? assoc-list?))
- )))
- ;; can be of type: (quote list-of-strings) or (quote assoc-list)
- ;; (opensmtpd-table-type record) returns the values' type. The user SHOULD NEVER set the type.
- ;; TODO jpoiret: on irc reccomends that I just use an outside function to determine fieldname 'values', type.
- ;; it would be "simpler" and possibly easier for the next person working on this code to understand what is happening.
- (type opensmtpd-table-type
- (default #f)
- (thunked)
- (sanitize (lambda (value)
- (cond [(opensmtpd-table-values this-record)
- (if (list-of-strings? (opensmtpd-table-values this-record))
- (quote list-of-strings)
- (quote assoc-list))]
- [(opensmtpd-table-file this-record)
- (if (opensmtpd-table-file-db this-record)
- (quote db)
- (quote file))]
- [else
- (display "opensmtpd-table-type is broke\n")
- (throw 'bad! value)])))))
- (define-record-type* <opensmtpd-ca>
- opensmtpd-ca make-opensmtpd-ca
- opensmtpd-ca?
- (name opensmtpd-ca-name
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-ca" "name" (list string?)))))
- (file opensmtpd-ca-file
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-ca" "file" (list string? file-exists?))))))
- (define-record-type* <opensmtpd-pki>
- opensmtpd-pki make-opensmtpd-pki
- opensmtpd-pki?
- (domain opensmtpd-pki-domain
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-pki" "domain" (list string?)))))
- (cert opensmtpd-pki-cert
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-pki" "cert" (list string? file-exists?)))))
- (key opensmtpd-pki-key
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-pki" "key" (list string? file-exists?))))))
- (define-record-type* <opensmtpd-lmtp-configuration>
- opensmtpd-lmtp-configuration make-opensmtpd-lmtp-configuration
- opensmtpd-lmtp-configuration?
- (destination opensmtpd-lmtp-configuration-destination
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-lmtp-configuration" "destination" (list string?)))))
- (rcpt-to opensmtpd-lmtp-configuration-rcpt-to
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-lmtp-configuration" "rcpt-to" (list false? string?))))))
- (define-record-type* <opensmtpd-mda-configuration>
- opensmtpd-mda-configuration make-opensmtpd-mda-configuration
- opensmtpd-mda-configuration?
- (command opensmtpd-mda-configuration-command
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-mda-configuration" "command" (list string?))))))
- (define-record-type* <opensmtpd-maildir-configuration>
- opensmtpd-maildir-configuration make-opensmtpd-maildir-configuration
- opensmtpd-maildir-configuration?
- (pathname opensmtpd-maildir-configuration-pathname
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-maildir-configuration" "pathname" (list false? string?)))))
- (junk opensmtpd-maildir-configuration-junk
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-maildir-configuration" "junk" (list boolean?))))))
- (define-record-type* <opensmtpd-local-delivery-configuration>
- opensmtpd-local-delivery-configuration make-opensmtpd-local-delivery-configuration
- opensmtpd-local-delivery-configuration?
- ;; method can be "mbox", "expand-only", "forward-only", <opensmtpd-lmtp>, <opensmtpd-maildir>, <opensmtpd-mda>
- ;; TODO let method be a list of any of the above types...should I do this? does that make sense?
- (method opensmtpd-local-delivery-configuration-method
- (default "mbox")
- (sanitize (lambda (value)
- (cond
- [(or (opensmtpd-lmtp-configuration? value)
- (opensmtpd-maildir-configuration? value)
- (opensmtpd-mda-configuration? value)
- (string=? value "mbox")
- (string=? value "expand-only")
- (string=? value "forward-only"))
- value]
- [else
- (begin
- (display (string-append "<opensmtpd-local-delivery-configuration> fieldname 'method' must be of type "
- "\"mbox\", \"expand-only\", \"forward-only\" "
- "<opensmtpd-lmtp-configuration>, <opensmtpd-maildir-configuration>, "
- "or <opensmtpd-mda-configuration>.\n"))
- (throw 'bad! value))]))))
- ;; string opensmtpd-table-configuration-name
- (alias opensmtpd-local-delivery-configuration-alias
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-local-delivery-configuration" "alias" (list false? string?)))))
- ;; string
- (ttl opensmtpd-local-delivery-configuration-ttl
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-local-delivery-configuration" "ttl" (list false? string?)))))
- (user opensmtpd-local-delivery-configuration-user
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-local-delivery-configuration" "user" (list false? string?)))))
- ;; needs to be of type string
- (userbase opensmtpd-local-delivery-configuration-userbase
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-local-delivery-configuration" "userbase" (list false? string?)))))
- (virtual opensmtpd-local-delivery-configuration-virtual
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-local-delivery-configuration" "virtual" (list false? string?)))))
- (wrapper opensmtpd-local-delivery-configuration-wrapper
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-local-delivery-configuration" "wrapper" (list false? string?))))))
- (define-record-type* <opensmtpd-relay-configuration>
- opensmtpd-relay-configuration make-opensmtpd-relay-configuration
- opensmtpd-relay-configuration?
- (backup opensmtpd-relay-configuration-backup ;; boolean
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-relay-configuration" "backup" (list boolean?)))))
- (backup-mx opensmtpd-relay-configuration-backup-mx ;; string mx name
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-relay-configuration" "backup-mx" (list false? string?)))))
- ;; string or heloname or <table name>
- ;; this combines options helo or helo-src
- (helo opensmtpd-relay-configuration-helo
- (default #f))
- ;; string domain OR <domains>
- (domain opensmtpd-relay-configuration-domain
- (default #f))
- ;; string
- (host opensmtpd-relay-configuration-host
- (default #f))
- ;; string or <opensmtpd-pki-configuration> string could be "gnucode.me", which is the
- ;; domain fieldname of <opensmtpd-pki-configuration>.
- (pki opensmtpd-relay-configuration-pki
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-relay-configuration" "pki" (list false? string?)))))
- ;; boolean
- (srs opensmtpd-relay-configuration-srs
- (default #f)
- (lambda (value)
- (my/sanitize value "opensmtpd-relay-configuration" "srs" (list boolean?))))
- ;; boolean or no-verify
- (tls opensmtpd-relay-configuration-tls
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-relay-configuration" "tls" (list false? string?)))))
- ;; string
- (protocols opensmtpd-relay-configuration-protocols
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-relay-configuration" "protocols" (list false? string?)))))
- ;; string
- (ciphers opensmtpd-relay-configuration-ciphers
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-relay-configuration" "ciphers" (list false? string?)))))
- ;; string like "<table>"
- (auth opensmtpd-relay-configuration-auth
- (default #f))
- (mail-from opensmtpd-relay-configuration-mail-from
- (default #f))
- ;; string "sourceaddr" or "<sourceadd>"
- (src opensmtpd-relay-configuration-src
- (default #f)))
- (define-record-type* <opensmtpd-action>
- opensmtpd-action make-opensmtpd-action
- opensmtpd-action?
- this-record
- (name opensmtpd-action-name
- (default "local"))
- ;; TODO add support for forward-only and expand-only
- ;; type <opensmtpd-local-delivery-configuration> or <opensmtpd-relay-configuration>
- ;; ;; local-delivery has a default value so (service opensmtpd-service) will just work for
- ;; ;; local email delivery
- (method opensmtpd-action-method
- (default (opensmtpd-local-delivery-configuration))
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-action" "method"
- (list opensmtpd-relay-configuration?
- opensmtpd-local-delivery-configuration?))))))
- ;; FIXME/TODO Perhaps it would be nice in the future to change filter names to "filters".
- ;; Then "filters" could either be a list of filter names, OR it could be a list of types
- ;; <opensmtpd-filter-phase>, <opensmtpd-filter-proc>, or <opensmtpd-filter-proc-exec>.
- ;; BUT then I would have to write more code...and it would get complicated. Seems like
- ;; to much work.
- ;;list of many records of type opensmtpd-filter-chain
- ;; FIXME/TODO? Perhaps I could make filter-chains accept a list like this:
- ;; (list (filter-chain (name "chain-filter")
- ;; (filters (list (filter-phase
- ;; (name "phase")
- ;; (conditions (list "rdns")))
- ;; (filter-proc-exec
- ;; (name "process")
- ;; (command "this command"))))))
- ;; then I could get rid of fieldnames filter-phases, filter-procs, and filter-proc-execs from
- ;; opensmtpd-configuration
- (define-record-type* <opensmtpd-filter-chain>
- opensmtpd-filter-chain make-opensmtpd-filter-chain
- opensmtpd-filter-chain?
- ;; string chain name
- (name opensmtpd-filter-chain-name
- (default "filter-chain")
- (sanitize
- (lambda (value)
- (my/sanitize value "opensmtpd-filter-chain" "chain-name" (list string?)))))
- ;; list of strings of filter-name
- ;; maybe someday this could support record types
- ;; <opensmtpd-filter-proc>, <opensmtpd-filter-proc-exec>, or <opensmtpd-filter-phase>
- (filter-names opensmtpd-filter-chain-filter-names
- (default #f)
- (sanitize
- (lambda (value)
- (my/sanitize value "opensmtpd-filter-chain" "filter-names" (list list-of-strings?))))))
- (define-record-type* <opensmtpd-filter-phase>
- opensmtpd-filter-phase make-opensmtpd-filter-phase
- opensmtpd-filter-phase?
- (name opensmtpd-filter-phase-name ;; string chain-name
- (default "filter-chain")
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-filter-phase" "name" (list string?)))))
- (phase-name opensmtpd-filter-phase-phase-name ;; string
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-filter-phase" "phase-name" (list string?)))))
- (conditions opensmtpd-filter-phase-conditions
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-filter-phase" "conditions-name" (list list-of-strings?)))))
- (decision opensmtpd-filter-phase-decision
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-filter-phase" "decision"
- (list
- (lambda (value)
- (if (or (string=? "bypass" value)
- (string=? "disconnect" value)
- (string=? "reject" value)
- (string=? "rewrite" value)
- (string=? "junk" value))
- value
- #f)))))))
- (message opensmtpd-filter-phase-message
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-filter-phase" "message" (list false? string?)))))
- (value opensmtpd-filter-phase-value
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-filter-phase" "value" (list false? integer?))))))
- (define-record-type* <opensmtpd-filter-proc>
- opensmtpd-filter-proc make-opensmtpd-filter-proc
- opensmtpd-filter-proc?
- (name opensmtpd-filter-proc-name
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-filter-proc" "name" (list? string?)))))
- (proc-name opensmtpd-proc-proc-name
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-filter-proc" "name" (list? string?))))))
- (define-record-type* <opensmtpd-filter-proc-exec>
- opensmtpd-filter-proc-exec make-opensmtpd-filter-proc-exec
- opensmtpd-filter-proc-exec?
- (name opensmtpd-filter-proc-exec-name
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-filter-proc-exec" "name" (list string?)))))
- ;; FIXME/TODO how do I let this accept a list of file-like objects and strings?
- (command opensmtpd-filter-proc-exec-command
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-filter-proc-exec" "command" (list string?))))))
- (define-record-type* <opensmtpd-listen-on>
- opensmtpd-listen-on make-opensmtpd-listen-on
- opensmtpd-listen-on?
- ;; interface may be an IP address, interface group, or domain name
- (interface opensmtpd-listen-on-interface
- (default "lo"))
- ;;FIXME/TODO? should I convert this lambda into a (my/sanitize) invocation?
- ;; NO. It's not worth the effort, and the code is cleaner/easier to understand without it.
- ;; I would have to make a string-in-strings? procedure, which I would use twice...
- ;; register that function with list-of-procedures->string
- ;; and modify my/sanitize to accept a procedure which accepts an argument.
- ;; eg: (my/sanitize value "opensmtpd-match" "decision" (list (cons string-in-strings? (list "reject" "accept"))
- (family opensmtpd-listen-on-family
- (default #f)
- (sanitize (lambda (value)
- (cond
- [(eq? #f value) ;; value == #f
- value]
- [(and (string? value)
- (or (string=? "inet4" value)
- (string=? "inet6" value)))
- value]
- [else
- (begin
- (display "<opensmtpd-listen-on> fieldname 'family' must be string \"inet4\" or \"inet6\".\n")
- (throw 'bad! value))]))))
- ;; this is a string of <authtable>
- (auth opensmtpd-listen-on-auth
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-listen-on" "auth" (list boolean? string?)))))
- (auth-optional opensmtpd-listen-on-auth-optional
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-listen-on" "auth-optional" (list boolean? string?)))))
- ;; do I need a ca entry?
- ;; string
- (filter opensmtpd-listen-on-filter
- (default #f))
- ;; string
- (hostname opensmtpd-listen-on-hostname
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-listen-on" "hostname" (list false? string?)))))
- ;; string of type <table>
- (hostnames opensmtpd-listen-on-hostnames
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-listen-on" "hostnames" (list false? string?)))))
- (mask-src opensmtpd-listen-on-mask-src
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-listen-on" "mask-src" (list boolean?)))))
- (no-dsn opensmtpd-listen-on-no-dsn
- (default #f))
- ;; string or pki record
- (pki opensmtpd-listen-on-pki
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-listen-on" "pki" (list false? string?)))))
- (port opensmtpd-listen-on-port
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-listen-on" "port" (list false? integer?)))))
- (proxy-v2 opensmtpd-listen-on-proxy-k2
- (default #f))
- (received-auth opensmtpd-listen-on-received-auth
- (default #f))
- ;; string or <opensmtpd-senders> record
- (senders opensmtpd-listen-on-senders
- (default #f))
- (secure-connection opensmtpd-listen-on-secure-connection
- (default #f)
- (sanitize (lambda (value)
- (cond [(boolean? value)
- value]
- [(and (string? value)
- (or (string=? "smtps" value)
- (string=? "tls" value)
- (string=? "tls-require" value)
- (string=? "tls-require-verify" value)))
- value]
- [else
- (begin
- (display (string-append "<opensmtd-listen-on> fieldname 'secure-connection' can be "
- "one of the following strings: \n'smtps', 'tls', 'tls-require', "
- "or 'tls-require-verify'.\n"))
- (throw 'bad! value))]))))
- ;; string
- (tag opensmtpd-listen-on-tag
- (default #f))
- (protocols opensmtpd-listen-on-protocols
- (default #f))
- (ciphers opensmtpd-listen-on-ciphers
- (default #f)))
- (define-record-type* <opensmtpd-listen-on-socket-configuration>
- opensmtpd-listen-on-socket-configuration make-opensmtpd-listen-on-socket-configuration
- opensmtpd-listen-on-socket-configuration?
- ;; string or <opensmtpd-filter> record or false
- (filter opensmtpd-listen-on-socket-configuration-filter
- (default #f))
- (mask-src opensmtpd-listen-on-socket-configuration-mask-src
- (default #f))
- ;; string
- (tag opensmtpd-listen-on-socket-configuration-tag
- (default #f)))
- (define-record-type* <opensmtpd-match>
- opensmtpd-match make-opensmtpd-match
- opensmtpd-match?
- (name opensmtpd-match-name ;; name is a string OR it is (quote reject), in which case the match
- (default #f) ;; rejects the incoming connection/envelope.
- (sanitize (lambda (value)
- (if (or (string? value)
- (eq? (quote reject) value))
- value
- (begin
- (display
- (string-append "<opensmtpd-match> fieldname 'name' is of type string or '(quote reject).\n"
- "If its value is '(quote reject), then the match rejects the incoming message\n"
- "during the SMTP dialogue.\n"))
- (throw 'bad! value))))))
- ;;FIXME/TODO? Perhaps I should add in a reject fieldname. If reject
- ;;is #t, then the match record will be a reject match record. That
- ;;way it's less confusing for users to type in
- ;; (opensmtpd-match (name 'reject)).
- ;; BUT then I have to make fieldnames 'name' and 'reject' mutually exclusive.
- ;; #f (empty) or a string
- ;; eg: "for any" "! for local" "for domain gnucode.me" "! for domain <domains>"
- ;; FIXME/TODO should I properly sanitize this? any string works now...
- (for opensmtpd-match-for
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-match" "for" (list false? string?)))))
- ;; #f (empty) or a string
- ;; eg: "from any" "from auth" "from auth user" "! from auth <users>" "from local" "! from rdns"
- (from opensmtpd-match-from
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-match" "from" (list false? string?)))))
- (auth opensmtpd-match-auth
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-match" "auth" (list false? string?)))))
- (helo opensmtpd-match-helo
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-match" "helo" (list false? string?)))))
- (mail-from opensmtpd-match-mail-from
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-match" "mail-from" (list false? string?)))))
- (rcpt-to opensmtpd-match-rcpt-to
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-match" "rcpt-to" (list false? string?)))))
- (tag opensmtpd-match-tag
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-match" "tag" (list false? string?)))))
- ;; hmmm. How should I handle this?
- ;; #f would mean "! tls", #nil would mean nothing, and #t would mean "tls"
- ;; FIXME/TODO, this default value should be #nil or '(), but the last time I did that,
- ;; reconfiguring failed...
- (tls opensmtpd-match-tls
- (default '())
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-match" "tls" (list boolean? null?))))))
- ;; this is for registering an already running process for opensmtpd
- (define-record-type* <opensmtpd-proc>
- opensmtpd-proc make-opensmtpd-proc
- opensmtpd-proc?
- (name opensmtpd-proc-name
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-proc" "name" (list false? string?)))))
- (command opensmtpd-proc-command
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-proc" "command" (list false? string?))))))
- (define-record-type* <opensmtpd-smtp-configuration>
- opensmtpd-smtp-configuration make-opensmtpd-smtp-configuration
- opensmtpd-smtp-configuration?
- (ciphers opensmtpd-configuration-ciphers
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-smtp-configuration" "ciphers" (list false? string?)))))
- (limit-max-mails opensmtpd-smtp-configuration-limit-max-mails
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-smtp-configuration" "limit-max-mails" (list false? integer?)))))
- (limit-max-rcpt opensmtpd-smtp-configuration-limit-max-rcpt
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-smtp-configuration" "limit-max-rcpt" (list false? integer?)))))
- (max-message-size opensmtpd-smtp-configuration-max-message-size
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-smtp-configuration" "max-message-size"
- (list false? integer? string?)))))
- ;; FIXME/TODO the sanitize function of sub-addr-delim should accept a string of length one not string?
- (sub-addr-delim opensmtpd-smtp-configuration-sub-addr-delim
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-smtp-configuration" "sub-addr-delim"
- (list false? integer? string?))))))
-
- (define-record-type* <opensmtpd-srs-configuration>
- opensmtpd-srs-configuration make-opensmtpd-srs-configuration
- opensmtpd-srs-configuration?
- (key opensmtpd-configuration-key
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-srs-configuration" "key" (list false? boolean? string?)))))
- (key-backup opensmtpd-srs-configuration-key-backup
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-srs-configuration" "key-backup" (list false? integer?)))))
- (ttl-delay opensmtpd-srs-configuration-ttl-delay
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-srs-configuration" "ttl-delay" (list false? string?))))))
- (define-record-type* <opensmtpd-queue-configuration>
- opensmtpd-queue-configuration make-opensmtpd-queue-configuration
- opensmtpd-queue-configuration?
- (compression opensmtpd-queue-configuration-compression
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-queue-configuration" "compression" (list boolean?)))))
- (encryption opensmtpd-configuration-encryption
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-queue-configuration" "encryption" (list false? file-exists? string?)))))
- (ttl-delay opensmtpd-queue-configuration-ttl-delay
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-queue-configuration" "ttl-delay" (list false? string?))))))
- (define-record-type* <opensmtpd-configuration>
- opensmtpd-configuration make-opensmtpd-configuration
- opensmtpd-configuration?
- (package opensmtpd-configuration-package
- (default opensmtpd))
- (config-file opensmtpd-configuration-config-file
- ;; TODO if you change this next line to
- ;; (default (opensmtpd-configuration)
- ;; you will create an infinite recursive list of <opensmtpd-configuration>.
- ;; bug-guix doesn't really consider this a bug, but a noobie footgun.
- ;; Guile will eventually refuse to compile if you use (opensmtpd-configuration)
- ;; BUT that error message is quite lame.
- (default #f))
- (actions opensmtpd-configuration-actions
- (default (list (opensmtpd-action
- (name "local")
- (method (opensmtpd-local-delivery-configuration
- (method "mbox"))))
- (opensmtpd-action
- (name "outbound")
- (method (opensmtpd-relay-configuration))))))
- ;; FIXME/TODO should I include a admd authservid entry?
- ;; string
- (bounce opensmtpd-configuration-bounce
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-configuration" "bounce"
- (list false? string?)))))
- (cas opensmtpd-configuration-cas
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-configuration" "cas" (list false? list-of-opensmtpd-ca?)))))
- ;;list of many records of type opensmtpd-filter-chain
- ;; FIXME/TODO? Perhaps I could make filter-chains accept a list like this:
- ;; (list (filter-chain (name "chain-filter")
- ;; (filters (list (filter-phase
- ;; (name "phase")
- ;; (conditions (list "rdns")))
- ;; (filter-proc-exec
- ;; (name "process")
- ;; (command "this command"))))))
- ;; then I could get rid of fieldnames filter-phases, filter-procs, and filter-proc-execs from
- ;; opensmtpd-configuration
- (filter-chains opensmtpd-configuration-filter-chains
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-configuration" "filter-chain"
- (list false? list-of-opensmtpd-filter-chain?))))
- (default #f))
- ;; list of many records of type opensmtpd-filter-phase
- (filter-phases opensmtpd-configuration-filter-phases
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-configuration" "filter-phases"
- (list false? list-of-opensmtpd-filter-phase?)))))
- ;; list of many records of type opensmtpd-filter-proc
- (filter-procs opensmtpd-configuration-filter-procs
- (default #f))
- ;; list of many records of type opensmtpd-filter-proc-exec
- (filter-proc-execs opensmtpd-configuration-filter-proc-execs
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-configuration" "filter-proc-execs"
- (list false? list-of-opensmtpd-filter-proc-exec?)))))
- ;; should I have an "include" entry?
- ;; list of many records of type opensmtpd-listen-on
- (listen-ons opensmtpd-configuration-listen-ons
- (default (list (opensmtpd-listen-on)))
- (sanitize (lambda (value)
- (if (list-of-opensmtpd-listen-on? value)
- value
- (begin
- (display "<opensmtpd-configuration> fieldname 'listen-ons' expects a list of records ")
- (display "of one or more <opensmtpd-listen-on> records.\n")
- (throw 'bad! value))))))
- ;; accepts type <opensmtpd-listen-on-socket-configuration>
- (listen-on-socket opensmtpd-configuration-listen-on-socket
- (default (opensmtpd-listen-on-socket-configuration)))
- (includes opensmtpd-configuration-includes ;; list of strings of absolute path names
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-configuration" "includes" (list false? list-of-strings?)))))
- (matches opensmtpd-configuration-matches
- (default (list (opensmtpd-match
- (name "local")
- (for "for local"))
- (opensmtpd-match
- (name "outbound")
- (from "from local")
- (for "for any")))))
- ;; list of many records of type mda-wrapper
- ;; TODO/FIXME support using gexps here
- ;; eg (list "name" gexp)
- (mda-wrappers opensmtpd-configuration-mda-wrappers
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-configuration" "pkis" (list false? string?)))))
- (mta-max-deferred opensmtpd-configuration-mta-max-deferred
- (default 100)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-configuration" "mta-max-deferred" (list number?)))))
- ;; list of many records of type pki
- (pkis opensmtpd-configuration-pkis
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-configuration" "pkis" (list false? list-of-opensmtpd-pki?)))))
- ;; list of many records of type proc
- (procs opensmtpd-configuration-procs
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-configuration" "procs" (list false? list-of-opensmtpd-proc?)))))
- ;; FIXME/TODO add queue, smtp, srs directives
- (queue opensmtpd-configuration-queue
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-configuration" "queue" (list false? opensmtpd-queue-configuration?)))))
- (smtp opensmtpd-configuration-smtp
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-configuration" "smtp" (list false? opensmtpd-smtp-configuration?)))))
- (srs opensmtpd-configuration-srs
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-configuration" "srs" (list false? opensmtpd-srs-configuration?)))))
- ;; list of many records of type opensmtpd-table
- (tables opensmtpd-configuration-tables
- (default #f)
- (sanitize (lambda (value)
- (my/sanitize value "opensmtpd-configuration" "procs" (list false? list-of-opensmtpd-table?))))))
- ;; given a list and procedure, this tests that each element of list is of type
- ;; ie: (list-of-type? list string?) tests each list is of type string.
- (define (list-of-type? list proc?)
- (if (and (list? list)
- (not (null? list)))
- (let loop ([list list])
- (if (null? list)
- #t
- (if (proc? (car list))
- (loop (cdr list))
- #f)))
- #f))
- (define (list-of-strings? list)
- (list-of-type? list string?))
- ;; FIXME/TODO? make all of this end like list-of-strings? It has an "s" in it.
- ;; list-of-opensmtpd-ca -> <opensmtpd-ca>s? or opensmtpd-cas?
- (define (list-of-opensmtpd-ca? list)
- (list-of-type? list opensmtpd-ca?))
- (define (list-of-opensmtpd-pki? list)
- (list-of-type? list opensmtpd-pki?))
- (define (list-of-opensmtpd-filter-phase? list)
- (list-of-type? list opensmtpd-filter-phase?))
- (define (list-of-opensmtpd-filter-chain? list)
- (list-of-type? list opensmtpd-filter-chain?))
- (define (list-of-opensmtpd-filter-proc-exec? list)
- (list-of-type? list opensmtpd-filter-proc-exec?))
- (define (list-of-opensmtpd-listen-on? list)
- (list-of-type? list opensmtpd-listen-on?))
- (define (list-of-opensmtpd-table? list)
- (list-of-type? list opensmtpd-table?))
- (define (list-of-opensmtpd-proc? list)
- (list-of-type? list opensmtpd-proc?))
- (define* (list-of-strings->string list
- #:key
- (string-delimiter ", ")
- (prepend "")
- (append "")
- (drop-right-number 2))
- (string-drop-right
- (string-append prepend
- (let loop ([list list])
- (if (null? list)
- ""
- (string-append (car list)
- string-delimiter
- (loop (cdr list)))))
- append)
- drop-right-number))
- ;; these next few functions help me to turn <table>s
- ;; into strings suitable to fit into "opensmtpd.conf".
- ;; at the moment I cannot define this by using list-of-type?
- ;; the first (not (null? assoc-list)) prevents that.
- (define (assoc-list? assoc-list)
- (list-of-type? assoc-list (lambda (pair)
- (if (and (pair? pair)
- (string? (car pair))
- (string? (cdr pair)))
- #t
- #f))))
- (define (assoc-list->string assoc-list)
- (string-drop-right
- (let loop ([assoc-list assoc-list])
- (if (null? assoc-list)
- ""
- ;; pair is (cons "hello" "world") -> ("hello" . "world")
- (let ([pair (car assoc-list)])
- (string-append
- (car pair)
- " = "
- (cdr pair)
- ", "
- (loop (cdr assoc-list))))))
- 2))
- ;; The following functions convert various records into strings.
- (define* (variable->string var)
- (if var
- (string-append var " ")
- ""))
- (define (list-of-variables->string list)
- (let loop [(list list)]
- (if (null? list)
- ""
- (string-append (variable->string (car list))
- (list-of-variables->string (cdr list))))))
- ;; can be of type: (quote list-of-strings) or (quote assoc-list)
- (define (opensmtpd-table->string table)
- (string-append "table " (opensmtpd-table-name table) " "
- (let ([type (opensmtpd-table-type table)])
- (cond [(eq? type (quote list-of-strings))
- (string-append "{ " (list-of-strings->string (opensmtpd-table-values table)) " }")]
- [(eq? type (quote assoc-list))
- (string-append "{ " (assoc-list->string (opensmtpd-table-values table)) " }")]
- [(eq? type (quote db))
- (string-append "db:" (opensmtpd-table-file table))]
- [(eq? type (quote file))
- (string-append "file:" (opensmtpd-table-file table))]
- [else (throw 'youMessedUp table)]))
- " \n"))
- (define (opensmtpd-listen-on->string record)
- (string-append "listen on "
- (opensmtpd-listen-on-interface record) " "
- (let ([hostname (opensmtpd-listen-on-hostname record)]
- [hostnames (opensmtpd-listen-on-hostnames record)]
- [filter (opensmtpd-listen-on-filter record)]
- [mask-src (opensmtpd-listen-on-mask-src record)]
- [tag (opensmtpd-listen-on-tag record)]
- [secure-connection (opensmtpd-listen-on-secure-connection record)]
- [port (opensmtpd-listen-on-port record)]
- [pki (opensmtpd-listen-on-pki record)]
- [auth (opensmtpd-listen-on-auth record)]
- [auth-optional (opensmtpd-listen-on-auth-optional record)])
- (string-append
- (if mask-src
- (string-append "mask-src ")
- "")
- (if hostname
- (string-append "hostname " hostname " ")
- "")
- (if hostnames
- (string-append "hostname <" hostnames "> ")
- "")
- (if filter
- (string-append "filter \"" filter "\" ")
- "")
- (if tag
- (string-append "tag \"" (opensmtpd-listen-on-tag record) "\" ")
- "")
- (if secure-connection
- (cond [(string=? "smtps" secure-connection)
- "smtps "]
- [(string=? "tls" secure-connection)
- "tls "]
- [(string=? "tls-require" secure-connection)
- "tls-require "]
- [(string=? "tls-require-verify" secure-connection)
- "tls-require verify "])
- "")
- (if port
- (string-append "port " (number->string port) " ")
- "")
- (if pki
- (string-append "pki " pki " ")
- "")
- (if auth
- (string-append "auth "
- (if (string? auth)
- (string-append "<" auth ">")
- ""))
- "")
- (if auth-optional
- (string-append "auth-optional "
- (if (string? auth-optional)
- (string-append "<" auth-optional ">")
- ""))
- "")
- "\n"))))
- (define (opensmtpd-relay-configuration->string record)
- (let ([host (opensmtpd-relay-configuration-host record)])
- (string-append "relay "
- ;; FIXME should I always quote the host fieldname? do I need to quote localhost via "localhost" ?
- (if host
- (string-append "host \"" host "\"")
- ""))))
- (define (opensmtpd-lmtp-configuration->string record)
- (string-append "lmtp "
- (opensmtpd-lmtp-configuration-destination record)
- (if (opensmtpd-lmtp-configuration-rcpt-to record)
- (begin
- " " (opensmtpd-lmtp-configuration-rcpt-to record))
- "")))
- (define (opensmtpd-mda-configuration->string record)
- (string-append "mda "
- (opensmtpd-mda-configuration-command record) " "))
- (define (opensmtpd-maildir-configuration->string record)
- (string-append "maildir "
- "\"" (opensmtpd-maildir-configuration-pathname record) "\""
- (if (opensmtpd-maildir-configuration-junk record)
- " junk"
- " ")))
- (define (opensmtpd-proc->string record)
- (string-append "proc "
- (opensmtpd-proc-name record) " "
- "\"" (opensmtpd-proc-command record) "\"\n"))
- (define (opensmtpd-local-delivery-configuration->string record)
- (let ([method (opensmtpd-local-delivery-configuration-method record)])
- (string-append
- (cond [(string? method)
- (string-append method " ")]
- [(opensmtpd-mda-configuration? method)
- (opensmtpd-mda-configuration->string method)]
- [(opensmtpd-lmtp-configuration? method)
- (opensmtpd-lmtp-configuration->string method)]
- [(opensmtpd-maildir-configuration? method)
- (opensmtpd-maildir-configuration->string method)])
- ;; FIXME/TODO support specifying alias file:/path/to/alias-file ?
- ;; I do not think that is something that I can do...
- (if (string? (opensmtpd-local-delivery-configuration-alias record))
- (string-append "alias <" (opensmtpd-local-delivery-configuration-alias record) "> ")
- ""))))
- (define (opensmtpd-action->string record)
- (string-append "action "
- "\"" (opensmtpd-action-name record) "\" "
- (cond [(opensmtpd-local-delivery-configuration? (opensmtpd-action-method record))
- (opensmtpd-local-delivery-configuration->string (opensmtpd-action-method record))]
- [(opensmtpd-relay-configuration? (opensmtpd-action-method record))
- (opensmtpd-relay-configuration->string (opensmtpd-action-method record))])
- " \n"))
- (define (opensmtpd-match->string record)
- (string-append "match "
- (let ([for (opensmtpd-match-for record)]
- [name (opensmtpd-match-name record)]
- [from (opensmtpd-match-from record)]
- [auth (opensmtpd-match-auth record)]
- [helo (opensmtpd-match-helo record)]
- [mail-from (opensmtpd-match-mail-from record)]
- [rcpt-to (opensmtpd-match-rcpt-to record)]
- [tag (opensmtpd-match-tag record)]
- [tls (opensmtpd-match-tls record)])
- (string-append
- (list-of-variables->string (list from for auth helo mail-from rcpt-to tag))
- (cond [tls "tls "]
- [(not tls) "! tls "]
- [(null? tls) ""])
- (if (string? name)
- (string-append "action " "\"" name "\" ")
- "reject ")
- "\n"))))
- (define (opensmtpd-ca->string record)
- (string-append "ca " (opensmtpd-ca-name record) " "
- "cert \"" (opensmtpd-ca-file record) "\"\n"))
- (define (opensmtpd-pki->string record)
- (string-append "pki "
- (opensmtpd-pki-domain record) " "
- "cert \"" (opensmtpd-pki-cert record) "\"\n"
- "pki "
- (opensmtpd-pki-domain record) " "
- "key \"" (opensmtpd-pki-key record) "\"\n"))
- (define (opensmtpd-filter-chain->string record)
- (string-append "filter "
- "\"" (opensmtpd-filter-chain-name record) "\" "
- "chain {"
- (list-of-strings->string (opensmtpd-filter-chain-filter-names record))
- "}\n"))
- (define (opensmtpd-filter-phase->string record)
- (let ([name (opensmtpd-filter-phase-name record)]
- [phase-name (opensmtpd-filter-phase-phase-name record)]
- [decision (opensmtpd-filter-phase-decision record)]
- [conditions (opensmtpd-filter-phase-conditions record)]
- [message (opensmtpd-filter-phase-message record)]
- [value (opensmtpd-filter-phase-value record)])
- (string-append "filter "
- "\"" name "\" "
- "phase " phase-name " "
- "match "
- (list-of-strings->string
- conditions #:string-delimiter " " #:drop-right-number 1)
- " "
- decision " "
- (if (or (string=? "reject" decision)
- (string=? "disconnect" decision))
- (string-append "\"" message "\"")
- "")
- (if (string=? "rewrite" decision)
- (string-append "rewrite " (number->string value))
- "")
- "\n")))
- ;; FIXME/TODO should I use format here srfi-28 ?
- ;; web.scm nginx does a (format #f "string" "another string")
- ;; this could be a list like (list (file-append opensmtpd-dkimsign "/libexec/filter") "-d gnucode.me -s /path/to/selector.cert")
- ;; Then opensmtpd-configuration->mixed-text-file could be rewritten to be something like
- ;; (mixed-text-file (eval `(string-append (opensmtpd-configuration-fieldname->string ...)) (gnu services mail)))
- ;; and of course (opensmtpd-filter-proc-exec->string would have to be rewritten to
- ;; (string-append "filter " \"name\" proc-exec \" ,@(command) \"
- (define (opensmtpd-filter-proc-exec->string record)
- (string-append "filter "
- "\"" (opensmtpd-filter-proc-exec-name record) "\" "
- "proc-exec " "\"" (opensmtpd-filter-proc-exec-command record) "\""
- "\n"))
- ;; FIXME/TODO do I need this? or want this? I am using a lambda function
- ;; that works fairly well below in the ";; write out the includes" line
- ;; or could I just use the variable->string function?
- ;; something like (variable->string string #:prepend "include \"" #:append "\"\n")
- (define (opensmtpd-configuration-listen->string string)
- (string-append
- "include \"" string "\"\n"))
- (define (opensmtpd-configuration-fieldname->string record fieldname-accessor record->string)
- (if (fieldname-accessor record)
- (begin
- (string-append
- (list-of-records->string (fieldname-accessor record) record->string) "\n"))
- ""))
- (define (list-of-records->string list-of-records record->string)
- (string-append
- (let loop ([list list-of-records])
- (if (null? list)
- ""
- (string-append
- (record->string (car list))
- (loop (cdr list)))))))
- (define (opensmtpd-configuration->mixed-text-file record)
- ;; should I use this named let instead? or should I give this a name...
- ;; (write-all-fieldnames (list (cons fieldname fieldname->string) (cons fieldname2 fieldname->string)))
- ;; (let loop ([list (list (cons opensmtpd-configuration-includes (lambda (string)
- ;; (string-append
- ;; "include \"" string "\"\n")))
- ;; (cons opensmtpd-configuration-tables opensmtpd-table->string)
- ;; (cons opensmtpd-configuration-pkis opensmtpd-pki->string))])
- ;; (if (null? list)
- ;; ""
- ;; (string-append (opensmtpd-configuration-fieldname->string record
- ;; (caar list)
- ;; (cdar list))
- ;; (loop (cadr list)))))
-
- (mixed-text-file
- "opensmtpd.conf"
- ;; write out the mta-max-deferred
- ;; (opensmtpd-configuration-fieldname->string record opensmtpd-configuration-mta-max-deferred
- ;; (lambda (value)
- ;; (string-append "mta max-deferred " (number->string value) "\n")))
- ;; write out the includes
- (opensmtpd-configuration-fieldname->string record opensmtpd-configuration-includes
- opensmtpd-configuration-listen->string)
- ;;write out all the tables
- (opensmtpd-configuration-fieldname->string record opensmtpd-configuration-tables opensmtpd-table->string)
- ;; write out all the cas
- (opensmtpd-configuration-fieldname->string record opensmtpd-configuration-cas opensmtpd-ca->string)
- ;; write out all the pkis
- (opensmtpd-configuration-fieldname->string record opensmtpd-configuration-pkis opensmtpd-pki->string)
- ;; write out all the procs
- (opensmtpd-configuration-fieldname->string record opensmtpd-configuration-procs opensmtpd-proc->string)
- ;; write all of the opensmtpd-configuration-filter-chains
- (opensmtpd-configuration-fieldname->string record
- opensmtpd-configuration-filter-chains opensmtpd-filter-chain->string)
- ;; write all of the opensmtpd-configuration-filter-phases
- (opensmtpd-configuration-fieldname->string record
- opensmtpd-configuration-filter-phases opensmtpd-filter-phase->string)
- ;; write all of the opensmtpd-filter-proc-exec
- (opensmtpd-configuration-fieldname->string record
- opensmtpd-configuration-filter-proc-execs opensmtpd-filter-proc-exec->string)
- ;; write all of the listen-on-records
- (opensmtpd-configuration-fieldname->string record opensmtpd-configuration-listen-ons
- opensmtpd-listen-on->string)
- ;; write all the actions
- (opensmtpd-configuration-fieldname->string record opensmtpd-configuration-actions
- opensmtpd-action->string)
- ;; write all of the matches
- (opensmtpd-configuration-fieldname->string record opensmtpd-configuration-matches opensmtpd-match->string)
- ))
- (define (opensmtpd-shepherd-service config)
- (list (shepherd-service
- (provision '(smtpd))
- (requirement '(loopback))
- (documentation "Run the OpenSMTPD daemon.")
- (start (let ((smtpd (file-append (opensmtpd-configuration-package config) "/sbin/smtpd")))
- #~(make-forkexec-constructor
- (list #$smtpd "-f" (or #$(opensmtpd-configuration-config-file config)
- #$(opensmtpd-configuration->mixed-text-file config)))
- #:pid-file "/var/run/smtpd.pid")))
- (stop #~(make-kill-destructor)))))
- (define %opensmtpd-accounts
- (list (user-group
- (name "smtpq")
- (system? #t))
- (user-account
- (name "smtpd")
- (group "nogroup")
- (system? #t)
- (comment "SMTP Daemon")
- (home-directory "/var/empty")
- (shell (file-append shadow "/sbin/nologin")))
- (user-account
- (name "smtpq")
- (group "smtpq")
- (system? #t)
- (comment "SMTPD Queue")
- (home-directory "/var/empty")
- (shell (file-append shadow "/sbin/nologin")))))
- (define (opensmtpd-activation config)
- (let ((smtpd (file-append (opensmtpd-configuration-package config) "/sbin/smtpd"))
- (config-file (opensmtpd-configuration-config-file config))
- (configuration (opensmtpd-configuration->mixed-text-file config)))
- #~(begin
- (use-modules (guix build utils))
- ;; Create mbox and spool directories.
- (mkdir-p "/var/mail")
- (mkdir-p "/var/spool/smtpd")
- (chmod "/var/spool/smtpd" #o711)
- (mkdir-p "/var/spool/mail")
- (chmod "/var/spool/mail" #o711)
- (display (string-append "smtpd: checking syntax of "
- (or
- #$config-file
- #$configuration)
- "\n"))
- (system* #$smtpd "-nf"
- (or
- #$config-file
- #$configuration)))))
- (define %opensmtpd-pam-services
- (list (unix-pam-service "smtpd")))
- (define opensmtpd-service-type
- (service-type
- (name 'opensmtpd)
- (extensions
- (list (service-extension account-service-type
- (const %opensmtpd-accounts))
- (service-extension activation-service-type
- opensmtpd-activation)
- (service-extension pam-root-service-type
- (const %opensmtpd-pam-services))
- (service-extension profile-service-type
- (compose list opensmtpd-configuration-package))
- (service-extension shepherd-root-service-type
- opensmtpd-shepherd-service)))
- (default-value (opensmtpd-configuration))
- (description "Run the Opensmtpd email server.")))
|