123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858385938603861386238633864386538663867386838693870387138723873387438753876387738783879388038813882388338843885388638873888388938903891389238933894389538963897389838993900390139023903390439053906390739083909391039113912391339143915391639173918391939203921392239233924392539263927392839293930393139323933393439353936393739383939394039413942394339443945394639473948394939503951395239533954395539563957395839593960396139623963396439653966396739683969397039713972397339743975397639773978397939803981398239833984398539863987398839893990399139923993399439953996399739983999400040014002400340044005400640074008400940104011401240134014401540164017401840194020402140224023402440254026402740284029403040314032403340344035403640374038403940404041404240434044404540464047404840494050405140524053405440554056405740584059406040614062406340644065406640674068406940704071407240734074407540764077407840794080408140824083408440854086408740884089409040914092409340944095409640974098409941004101410241034104410541064107410841094110411141124113411441154116411741184119412041214122412341244125412641274128412941304131413241334134413541364137413841394140414141424143414441454146414741484149415041514152415341544155415641574158415941604161416241634164416541664167416841694170417141724173417441754176417741784179418041814182418341844185418641874188418941904191419241934194419541964197419841994200420142024203420442054206420742084209421042114212421342144215421642174218421942204221422242234224422542264227422842294230423142324233423442354236423742384239424042414242424342444245424642474248424942504251425242534254425542564257425842594260426142624263426442654266426742684269427042714272427342744275427642774278427942804281428242834284428542864287428842894290429142924293429442954296429742984299430043014302430343044305430643074308430943104311431243134314431543164317431843194320432143224323432443254326432743284329433043314332433343344335433643374338433943404341434243434344434543464347434843494350435143524353435443554356435743584359436043614362436343644365436643674368436943704371437243734374437543764377437843794380438143824383438443854386438743884389439043914392439343944395439643974398439944004401440244034404440544064407440844094410441144124413441444154416441744184419442044214422442344244425442644274428442944304431443244334434443544364437443844394440444144424443444444454446444744484449445044514452445344544455445644574458445944604461446244634464446544664467446844694470447144724473447444754476447744784479448044814482448344844485448644874488448944904491449244934494449544964497449844994500450145024503450445054506450745084509 |
- ;;; GNU Guix --- Functional package management for GNU
- ;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
- ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
- ;;; Copyright © 2017 Carlo Zancanaro <carlo@zancanaro.id.au>
- ;;; Copyright © 2017, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
- ;;; Copyright © 2019 Kristofer Buffington <kristoferbuffington@gmail.com>
- ;;; Copyright © 2020 Jonathan Brielmaier <jonathan.brielmaier@web.de>
- ;;;
- ;;; This file is part of GNU Guix.
- ;;;
- ;;; GNU Guix is free software; you can redistribute it and/or modify it
- ;;; under the terms of the GNU General Public License as published by
- ;;; the Free Software Foundation; either version 3 of the License, or (at
- ;;; your option) any later version.
- ;;;
- ;;; GNU Guix is distributed in the hope that it will be useful, but
- ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
- ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ;;; GNU General Public License for more details.
- ;;;
- ;;; You should have received a copy of the GNU General Public License
- ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
- ;;;
- ;;; Some of the help text was taken from the default dovecot.conf files.
- (define-module (gnu services mail)
- #: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 system setuid)
- #:use-module (gnu packages mail)
- #:use-module (gnu packages admin)
- #:use-module (gnu packages dav)
- #:use-module (gnu packages tls)
- #:use-module (guix i18n)
- #:use-module (guix diagnostics)
- #:use-module (guix ui)
- #:use-module (guix utils)
- #: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 (dovecot-service
- dovecot-service-type
- dovecot-configuration
- opaque-dovecot-configuration
- dict-configuration
- passdb-configuration
- userdb-configuration
- unix-listener-configuration
- fifo-listener-configuration
- inet-listener-configuration
- service-configuration
- protocol-configuration
- plugin-configuration
- mailbox-configuration
- namespace-configuration
- opensmtpd-table
- opensmtpd-table?
- opensmtpd-table-name
- opensmtpd-table-data
- opensmtpd-ca
- opensmtpd-ca?
- opensmtpd-ca-name
- opensmtpd-ca-file
- opensmtpd-pki
- opensmtpd-pki?
- opensmtpd-pki-domain
- opensmtpd-pki-cert
- opensmtpd-pki-key
- opensmtpd-pki-dhe
- opensmtpd-local-delivery
- opensmtpd-local-delivery?
- opensmtpd-local-delivery-method
- opensmtpd-local-delivery-alias
- opensmtpd-local-delivery-ttl
- opensmtpd-local-delivery-user
- opensmtpd-local-delivery-userbase
- opensmtpd-local-delivery-virtual
- opensmtpd-local-delivery-wrapper
- opensmtpd-maildir
- opensmtpd-maildir?
- opensmtpd-maildir-pathname
- opensmtpd-maildir-junk
- opensmtpd-mda
- opensmtpd-mda-name
- opensmtpd-mda-command
- opensmtpd-lmtp
- opensmtpd-lmtp-destination
- opensmtpd-lmtp-rcpt
- opensmtpd-relay
- opensmtpd-relay?
- opensmtpd-relay-name
- opensmtpd-relay-backup
- opensmtpd-relay-backup-mx
- opensmtpd-relay-helo
- opensmtpd-relay-domain
- opensmtpd-relay-host
- opensmtpd-relay-pki
- opensmtpd-relay-srs
- opensmtpd-relay-tls
- opensmtpd-relay-auth
- opensmtpd-relay-mail-from
- opensmtpd-relay-src
- opensmtpd-option
- opensmtpd-option?
- opensmtpd-option-option
- opensmtpd-option-bool
- opensmtpd-option-regex
- opensmtpd-option-data
- opensmtpd-filter-phase
- opensmtpd-filter-phase?
- opensmtpd-filter-phase-name
- opensmtpd-filter-phase-phase
- opensmtpd-filter-phase-options
- opensmtpd-filter-phase-decision
- opensmtpd-filter-phase-message
- opensmtpd-filter-phase-value
- opensmtpd-filter
- opensmtpd-filter?
- opensmtpd-filter-name
- opensmtpd-filter-proc
- opensmtpd-interface
- opensmtpd-interface?
- opensmtpd-interface-interface
- opensmtpd-interface-family
- opensmtpd-interface-auth
- opensmtpd-interface-auth-optional
- opensmtpd-interface-filters
- opensmtpd-interface-hostname
- opensmtpd-interface-hostnames
- opensmtpd-interface-mask-src
- opensmtpd-interface-disable-dsn
- opensmtpd-interface-pki
- opensmtpd-interface-port
- opensmtpd-interface-proxy-v2
- opensmtpd-interface-received-auth
- opensmtpd-interface-senders
- opensmtpd-interface-masquerade
- opensmtpd-interface-secure-connection
- opensmtpd-interface-tag
- opensmtpd-socket
- opensmtpd-socket?
- opensmtpd-socket-filters
- opensmtpd-socket-mask-src
- opensmtpd-socket-tag
- opensmtpd-match
- opensmtpd-match?
- opensmtpd-match-action
- opensmtpd-match-options
- opensmtpd-smtp
- opensmtpd-smtp?
- opensmtpd-smtp-ciphers
- opensmtpd-smtp-limit-max-mails
- opensmtpd-smtp-limit-max-rcpt
- opensmtpd-smtp-max-message-size
- opensmtpd-smtp-sub-addr-delim character
- opensmtpd-srs
- opensmtpd-srs?
- opensmtpd-srs-key
- opensmtpd-srs-backup-key
- opensmtpd-srs-ttl-delay
- opensmtpd-queue
- opensmtpd-queue?
- opensmtpd-queue-compression
- opensmtpd-queue-encryption
- opensmtpd-queue-ttl-delay
- opensmtpd-configuration
- opensmtpd-configuration?
- opensmtpd-package
- opensmtpd-config-file
- opensmtpd-configuration-bounce
- opensmtpd-configuration-cas
- opensmtpd-configuration-interfaces
- opensmtpd-configuration-socket
- opensmtpd-configuration-includes
- opensmtpd-configuration-matches
- ;;opensmtpd-configuration-mda-wrappers
- opensmtpd-configuration-mta-max-deferred
- opensmtpd-configuration-srs
- opensmtpd-configuration-smtp
- opensmtpd-configuration-queue
- opensmtpd-service-type
- mail-aliases-service-type
- exim-configuration
- exim-configuration?
- exim-service-type
- %default-exim-config-file
- imap4d-configuration
- imap4d-configuration?
- imap4d-service-type
- %default-imap4d-config-file
- radicale-configuration
- radicale-configuration?
- radicale-service-type
- %default-radicale-config-file))
- ;;; Commentary:
- ;;;
- ;;; This module provides service definitions for the Dovecot POP3 and IMAP
- ;;; mail server.
- ;;;
- ;;; Code:
- (define (uglify-field-name field-name)
- (let ((str (symbol->string field-name)))
- (string-join (string-split (if (string-suffix? "?" str)
- (substring str 0 (1- (string-length str)))
- str)
- #\-)
- "_")))
- (define (serialize-field field-name val)
- (format #t "~a=~a\n" (uglify-field-name field-name) val))
- (define (serialize-string field-name val)
- (serialize-field field-name val))
- (define (space-separated-string-list? val)
- (and (list? val)
- (and-map (lambda (x)
- (and (string? x) (not (string-index x #\space))))
- val)))
- (define (serialize-space-separated-string-list field-name val)
- (match val
- (() #f)
- (_ (serialize-field field-name (string-join val " ")))))
- (define (comma-separated-string-list? val)
- (and (list? val)
- (and-map (lambda (x)
- (and (string? x) (not (string-index x #\,))))
- val)))
- (define (serialize-comma-separated-string-list field-name val)
- (serialize-field field-name (string-join val ",")))
- (define (file-name? val)
- (and (string? val)
- (string-prefix? "/" val)))
- (define (serialize-file-name field-name val)
- (serialize-string field-name val))
- (define (colon-separated-file-name-list? val)
- (and (list? val)
- ;; Trailing slashes not needed and not
- (and-map file-name? val)))
- (define (serialize-colon-separated-file-name-list field-name val)
- (serialize-field field-name (string-join val ":")))
- (define (serialize-boolean field-name val)
- (serialize-string field-name (if val "yes" "no")))
- (define (non-negative-integer? val)
- (and (exact-integer? val) (not (negative? val))))
- (define (serialize-non-negative-integer field-name val)
- (serialize-field field-name val))
- (define (hours? val) (non-negative-integer? val))
- (define (serialize-hours field-name val)
- (serialize-field field-name (format #f "~a hours" val)))
- (define (free-form-fields? val)
- (match val
- (() #t)
- ((((? symbol?) . (? string?)) . val) (free-form-fields? val))
- (_ #f)))
- (define (serialize-free-form-fields field-name val)
- (for-each (match-lambda ((k . v) (serialize-field k v))) val))
- (define (free-form-args? val)
- (match val
- (() #t)
- ((((? symbol?) . (? string?)) . val) (free-form-args? val))
- (_ #f)))
- (define (serialize-free-form-args field-name val)
- (serialize-field field-name
- (string-join
- (map (match-lambda ((k . v) (format #f "~a=~a" k v))) val)
- " ")))
- (define-configuration dict-configuration
- (entries
- (free-form-fields '())
- "A list of key-value pairs that this dict should hold."))
- (define (serialize-dict-configuration field-name val)
- (format #t "dict {\n")
- (serialize-configuration val dict-configuration-fields)
- (format #t "}\n"))
- (define-configuration passdb-configuration
- (driver
- (string "pam")
- "The driver that the passdb should use. Valid values include
- @samp{pam}, @samp{passwd}, @samp{shadow}, @samp{bsdauth}, and
- @samp{static}.")
- (args
- (space-separated-string-list '())
- "Space separated list of arguments to the passdb driver."))
- (define (serialize-passdb-configuration field-name val)
- (format #t "passdb {\n")
- (serialize-configuration val passdb-configuration-fields)
- (format #t "}\n"))
- (define (passdb-configuration-list? val)
- (and (list? val) (and-map passdb-configuration? val)))
- (define (serialize-passdb-configuration-list field-name val)
- (for-each (lambda (val) (serialize-passdb-configuration field-name val)) val))
- (define-configuration userdb-configuration
- (driver
- (string "passwd")
- "The driver that the userdb should use. Valid values include
- @samp{passwd} and @samp{static}.")
- (args
- (space-separated-string-list '())
- "Space separated list of arguments to the userdb driver.")
- (override-fields
- (free-form-args '())
- "Override fields from passwd."))
- (define (serialize-userdb-configuration field-name val)
- (format #t "userdb {\n")
- (serialize-configuration val userdb-configuration-fields)
- (format #t "}\n"))
- (define (userdb-configuration-list? val)
- (and (list? val) (and-map userdb-configuration? val)))
- (define (serialize-userdb-configuration-list field-name val)
- (for-each (lambda (val) (serialize-userdb-configuration field-name val)) val))
- (define-configuration unix-listener-configuration
- (path
- (string (configuration-missing-field 'unix-listener 'path))
- "Path to the file, relative to @code{base-dir} field. This is also used as
- the section name.")
- (mode
- (string "0600")
- "The access mode for the socket.")
- (user
- (string "")
- "The user to own the the socket.")
- (group
- (string "")
- "The group to own the socket."))
- (define (serialize-unix-listener-configuration field-name val)
- (format #t "unix_listener ~a {\n" (unix-listener-configuration-path val))
- (serialize-configuration val (cdr unix-listener-configuration-fields))
- (format #t "}\n"))
- (define-configuration fifo-listener-configuration
- (path
- (string (configuration-missing-field 'fifo-listener 'path))
- "Path to the file, relative to @code{base-dir} field. This is also used as
- the section name.")
- (mode
- (string "0600")
- "The access mode for the socket.")
- (user
- (string "")
- "The user to own the the socket.")
- (group
- (string "")
- "The group to own the socket."))
- (define (serialize-fifo-listener-configuration field-name val)
- (format #t "fifo_listener ~a {\n" (fifo-listener-configuration-path val))
- (serialize-configuration val (cdr fifo-listener-configuration-fields))
- (format #t "}\n"))
- (define-configuration inet-listener-configuration
- (protocol
- (string (configuration-missing-field 'inet-listener 'protocol))
- "The protocol to listen for.")
- (address
- (string "")
- "The address on which to listen, or empty for all addresses.")
- (port
- (non-negative-integer
- (configuration-missing-field 'inet-listener 'port))
- "The port on which to listen.")
- (ssl?
- (boolean #t)
- "Whether to use SSL for this service; @samp{yes}, @samp{no}, or
- @samp{required}."))
- (define (serialize-inet-listener-configuration field-name val)
- (format #t "inet_listener ~a {\n" (inet-listener-configuration-protocol val))
- (serialize-configuration val (cdr inet-listener-configuration-fields))
- (format #t "}\n"))
- (define (listener-configuration? val)
- (or (unix-listener-configuration? val)
- (fifo-listener-configuration? val)
- (inet-listener-configuration? val)))
- (define (serialize-listener-configuration field-name val)
- (cond
- ((unix-listener-configuration? val)
- (serialize-unix-listener-configuration field-name val))
- ((fifo-listener-configuration? val)
- (serialize-fifo-listener-configuration field-name val))
- ((inet-listener-configuration? val)
- (serialize-inet-listener-configuration field-name val))
- (else (configuration-field-error #f field-name val))))
- (define (listener-configuration-list? val)
- (and (list? val) (and-map listener-configuration? val)))
- (define (serialize-listener-configuration-list field-name val)
- (for-each (lambda (val)
- (serialize-listener-configuration field-name val))
- val))
- (define-configuration service-configuration
- (kind
- (string (configuration-missing-field 'service 'kind))
- "The service kind. Valid values include @code{director},
- @code{imap-login}, @code{pop3-login}, @code{lmtp}, @code{imap},
- @code{pop3}, @code{auth}, @code{auth-worker}, @code{dict},
- @code{tcpwrap}, @code{quota-warning}, or anything else.")
- (listeners
- (listener-configuration-list '())
- "Listeners for the service. A listener is either an
- @code{unix-listener-configuration}, a @code{fifo-listener-configuration}, or
- an @code{inet-listener-configuration}.")
- (client-limit
- (non-negative-integer 0)
- "Maximum number of simultaneous client connections per process. Once this
- number of connections is received, the next incoming connection will prompt
- Dovecot to spawn another process. If set to 0, @code{default-client-limit} is
- used instead.")
- (service-count
- (non-negative-integer 1)
- "Number of connections to handle before starting a new process.
- Typically the only useful values are 0 (unlimited) or 1. 1 is more
- secure, but 0 is faster. <doc/wiki/LoginProcess.txt>.")
- (process-limit
- (non-negative-integer 0)
- "Maximum number of processes that can exist for this service. If set to 0,
- @code{default-process-limit} is used instead.")
- (process-min-avail
- (non-negative-integer 0)
- "Number of processes to always keep waiting for more connections.")
- ;; FIXME: Need to be able to take the default for this value from other
- ;; parts of the config.
- (vsz-limit
- (non-negative-integer #e256e6)
- "If you set @samp{service-count 0}, you probably need to grow
- this."))
- (define (serialize-service-configuration field-name val)
- (format #t "service ~a {\n" (service-configuration-kind val))
- (serialize-configuration val (cdr service-configuration-fields))
- (format #t "}\n"))
- (define (service-configuration-list? val)
- (and (list? val) (and-map service-configuration? val)))
- (define (serialize-service-configuration-list field-name val)
- (for-each (lambda (val)
- (serialize-service-configuration field-name val))
- val))
- (define-configuration protocol-configuration
- (name
- (string (configuration-missing-field 'protocol 'name))
- "The name of the protocol.")
- (auth-socket-path
- (string "/var/run/dovecot/auth-userdb")
- "UNIX socket path to master authentication server to find users.
- This is used by imap (for shared users) and lda.")
- (mail-plugins
- (space-separated-string-list '("$mail_plugins"))
- "Space separated list of plugins to load.")
- (mail-max-userip-connections
- (non-negative-integer 10)
- "Maximum number of IMAP connections allowed for a user from each IP
- address. NOTE: The username is compared case-sensitively.")
- (imap-metadata?
- (boolean #f)
- "Whether to enable the @code{IMAP METADATA} extension as defined in
- @uref{https://tools.ietf.org/html/rfc5464, RFC@tie{}5464}, which provides
- a means for clients to set and retrieve per-mailbox, per-user metadata
- and annotations over IMAP.
- If this is @samp{#t}, you must also specify a dictionary @i{via} the
- @code{mail-attribute-dict} setting.")
- (managesieve-notify-capability
- (space-separated-string-list '())
- "Which NOTIFY capabilities to report to clients that first connect to
- the ManageSieve service, before authentication. These may differ from the
- capabilities offered to authenticated users. If this field is left empty,
- report what the Sieve interpreter supports by default.")
- (managesieve-sieve-capability
- (space-separated-string-list '())
- "Which SIEVE capabilities to report to clients that first connect to
- the ManageSieve service, before authentication. These may differ from the
- capabilities offered to authenticated users. If this field is left empty,
- report what the Sieve interpreter supports by default."))
- (define (serialize-protocol-configuration field-name val)
- (format #t "protocol ~a {\n" (protocol-configuration-name val))
- (serialize-configuration val (cdr protocol-configuration-fields))
- (format #t "}\n"))
- (define (protocol-configuration-list? val)
- (and (list? val) (and-map protocol-configuration? val)))
- (define (serialize-protocol-configuration-list field-name val)
- (serialize-field 'protocols
- (string-join (map protocol-configuration-name val) " "))
- (for-each (lambda (val)
- (serialize-protocol-configuration field-name val))
- val))
- (define-configuration plugin-configuration
- (entries
- (free-form-fields '())
- "A list of key-value pairs that this dict should hold."))
- (define (serialize-plugin-configuration field-name val)
- (format #t "plugin {\n")
- (serialize-configuration val plugin-configuration-fields)
- (format #t "}\n"))
- (define-configuration mailbox-configuration
- (name
- (string (error "mailbox name is required"))
- "Name for this mailbox.")
- (auto
- (string "no")
- "@samp{create} will automatically create this mailbox.
- @samp{subscribe} will both create and subscribe to the mailbox.")
- (special-use
- (space-separated-string-list '())
- "List of IMAP @code{SPECIAL-USE} attributes as specified by RFC 6154.
- Valid values are @code{\\All}, @code{\\Archive}, @code{\\Drafts},
- @code{\\Flagged}, @code{\\Junk}, @code{\\Sent}, and @code{\\Trash}."))
- (define (serialize-mailbox-configuration field-name val)
- (format #t "mailbox \"~a\" {\n" (mailbox-configuration-name val))
- (serialize-configuration val (cdr mailbox-configuration-fields))
- (format #t "}\n"))
- (define (mailbox-configuration-list? val)
- (and (list? val) (and-map mailbox-configuration? val)))
- (define (serialize-mailbox-configuration-list field-name val)
- (for-each (lambda (val)
- (serialize-mailbox-configuration field-name val))
- val))
- (define-configuration namespace-configuration
- (name
- (string (error "namespace name is required"))
- "Name for this namespace.")
- (type
- (string "private")
- "Namespace type: @samp{private}, @samp{shared} or @samp{public}.")
- (separator
- (string "")
- "Hierarchy separator to use. You should use the same separator for
- all namespaces or some clients get confused. @samp{/} is usually a good
- one. The default however depends on the underlying mail storage
- format.")
- (prefix
- (string "")
- "Prefix required to access this namespace. This needs to be
- different for all namespaces. For example @samp{Public/}.")
- (location
- (string "")
- "Physical location of the mailbox. This is in same format as
- mail_location, which is also the default for it.")
- (inbox?
- (boolean #f)
- "There can be only one INBOX, and this setting defines which
- namespace has it.")
- (hidden?
- (boolean #f)
- "If namespace is hidden, it's not advertised to clients via NAMESPACE
- extension. You'll most likely also want to set @samp{list? #f}. This is mostly
- useful when converting from another server with different namespaces
- which you want to deprecate but still keep working. For example you can
- create hidden namespaces with prefixes @samp{~/mail/}, @samp{~%u/mail/}
- and @samp{mail/}.")
- (list?
- (boolean #t)
- "Show the mailboxes under this namespace with LIST command. This
- makes the namespace visible for clients that don't support NAMESPACE
- extension. The special @code{children} value lists child mailboxes, but
- hides the namespace prefix.")
- (subscriptions?
- (boolean #t)
- "Namespace handles its own subscriptions. If set to @code{#f}, the
- parent namespace handles them. The empty prefix should always have this
- as @code{#t}.)")
- (mailboxes
- (mailbox-configuration-list '())
- "List of predefined mailboxes in this namespace."))
- (define (serialize-namespace-configuration field-name val)
- (format #t "namespace ~a {\n" (namespace-configuration-name val))
- (serialize-configuration val (cdr namespace-configuration-fields))
- (format #t "}\n"))
- (define (list-of-namespace-configuration? val)
- (and (list? val) (and-map namespace-configuration? val)))
- (define (serialize-list-of-namespace-configuration field-name val)
- (for-each (lambda (val)
- (serialize-namespace-configuration field-name val))
- val))
- (define-configuration dovecot-configuration
- (dovecot
- (file-like dovecot)
- "The dovecot package.")
- (listen
- (comma-separated-string-list '("*" "::"))
- "A list of IPs or hosts where to listen in for connections. @samp{*}
- listens in all IPv4 interfaces, @samp{::} listens in all IPv6
- interfaces. If you want to specify non-default ports or anything more
- complex, customize the address and port fields of the
- @samp{inet-listener} of the specific services you are interested in.")
- (dict
- (dict-configuration (dict-configuration))
- "Dict configuration, as created by the @code{dict-configuration}
- constructor.")
- (passdbs
- (passdb-configuration-list (list (passdb-configuration (driver "pam"))))
- "List of passdb configurations, each one created by the
- @code{passdb-configuration} constructor.")
- (userdbs
- (userdb-configuration-list (list (userdb-configuration (driver "passwd"))))
- "List of userdb configurations, each one created by the
- @code{userdb-configuration} constructor.")
- (plugin-configuration
- (plugin-configuration (plugin-configuration))
- "Plug-in configuration, created by the @code{plugin-configuration}
- constructor.")
- (namespaces
- (list-of-namespace-configuration
- (list
- (namespace-configuration
- (name "inbox")
- (prefix "")
- (inbox? #t)
- (mailboxes
- (list
- (mailbox-configuration (name "Drafts") (special-use '("\\Drafts")))
- (mailbox-configuration (name "Junk") (special-use '("\\Junk")))
- (mailbox-configuration (name "Trash") (special-use '("\\Trash")))
- (mailbox-configuration (name "Sent") (special-use '("\\Sent")))
- (mailbox-configuration (name "Sent Messages") (special-use '("\\Sent")))
- (mailbox-configuration (name "Drafts") (special-use '("\\Drafts"))))))))
- "List of namespaces. Each item in the list is created by the
- @code{namespace-configuration} constructor.")
- (base-dir
- (file-name "/var/run/dovecot/")
- "Base directory where to store runtime data.")
- (login-greeting
- (string "Dovecot ready.")
- "Greeting message for clients.")
- (login-trusted-networks
- (space-separated-string-list '())
- "List of trusted network ranges. Connections from these IPs are
- allowed to override their IP addresses and ports (for logging and for
- authentication checks). @samp{disable-plaintext-auth} is also ignored
- for these networks. Typically you'd specify your IMAP proxy servers
- here.")
- (login-access-sockets
- (space-separated-string-list '())
- "List of login access check sockets (e.g. tcpwrap).")
- (verbose-proctitle?
- (boolean #f)
- "Show more verbose process titles (in ps). Currently shows user name
- and IP address. Useful for seeing who are actually using the IMAP
- processes (e.g. shared mailboxes or if same uid is used for multiple
- accounts).")
- (shutdown-clients?
- (boolean #t)
- "Should all processes be killed when Dovecot master process shuts down.
- Setting this to @code{#f} means that Dovecot can be upgraded without
- forcing existing client connections to close (although that could also
- be a problem if the upgrade is e.g. because of a security fix).")
- (doveadm-worker-count
- (non-negative-integer 0)
- "If non-zero, run mail commands via this many connections to doveadm
- server, instead of running them directly in the same process.")
- (doveadm-socket-path
- (string "doveadm-server")
- "UNIX socket or host:port used for connecting to doveadm server.")
- (import-environment
- (space-separated-string-list '("TZ"))
- "List of environment variables that are preserved on Dovecot startup
- and passed down to all of its child processes. You can also give
- key=value pairs to always set specific settings.")
- ;;; Authentication processes
- (disable-plaintext-auth?
- (boolean #t)
- "Disable LOGIN command and all other plaintext authentications unless
- SSL/TLS is used (LOGINDISABLED capability). Note that if the remote IP
- matches the local IP (i.e. you're connecting from the same computer),
- the connection is considered secure and plaintext authentication is
- allowed. See also ssl=required setting.")
- (auth-cache-size
- (non-negative-integer 0)
- "Authentication cache size (e.g. @samp{#e10e6}). 0 means it's disabled.
- Note that bsdauth, PAM and vpopmail require @samp{cache-key} to be set
- for caching to be used.")
- (auth-cache-ttl
- (string "1 hour")
- "Time to live for cached data. After TTL expires the cached record
- is no longer used, *except* if the main database lookup returns internal
- failure. We also try to handle password changes automatically: If
- user's previous authentication was successful, but this one wasn't, the
- cache isn't used. For now this works only with plaintext
- authentication.")
- (auth-cache-negative-ttl
- (string "1 hour")
- "TTL for negative hits (user not found, password mismatch).
- 0 disables caching them completely.")
- (auth-realms
- (space-separated-string-list '())
- "List of realms for SASL authentication mechanisms that need them.
- You can leave it empty if you don't want to support multiple realms.
- Many clients simply use the first one listed here, so keep the default
- realm first.")
- (auth-default-realm
- (string "")
- "Default realm/domain to use if none was specified. This is used for
- both SASL realms and appending @@domain to username in plaintext
- logins.")
- (auth-username-chars
- (string
- "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890.-_@")
- "List of allowed characters in username. If the user-given username
- contains a character not listed in here, the login automatically fails.
- This is just an extra check to make sure user can't exploit any
- potential quote escaping vulnerabilities with SQL/LDAP databases. If
- you want to allow all characters, set this value to empty.")
- (auth-username-translation
- (string "")
- "Username character translations before it's looked up from
- databases. The value contains series of from -> to characters. For
- example @samp{#@@/@@} means that @samp{#} and @samp{/} characters are
- translated to @samp{@@}.")
- (auth-username-format
- (string "%Lu")
- "Username formatting before it's looked up from databases. You can
- use the standard variables here, e.g. %Lu would lowercase the username,
- %n would drop away the domain if it was given, or @samp{%n-AT-%d} would
- change the @samp{@@} into @samp{-AT-}. This translation is done after
- @samp{auth-username-translation} changes.")
- (auth-master-user-separator
- (string "")
- "If you want to allow master users to log in by specifying the master
- username within the normal username string (i.e. not using SASL
- mechanism's support for it), you can specify the separator character
- here. The format is then <username><separator><master username>.
- UW-IMAP uses @samp{*} as the separator, so that could be a good
- choice.")
- (auth-anonymous-username
- (string "anonymous")
- "Username to use for users logging in with ANONYMOUS SASL
- mechanism.")
- (auth-worker-max-count
- (non-negative-integer 30)
- "Maximum number of dovecot-auth worker processes. They're used to
- execute blocking passdb and userdb queries (e.g. MySQL and PAM).
- They're automatically created and destroyed as needed.")
- (auth-gssapi-hostname
- (string "")
- "Host name to use in GSSAPI principal names. The default is to use
- the name returned by gethostname(). Use @samp{$ALL} (with quotes) to
- allow all keytab entries.")
- (auth-krb5-keytab
- (string "")
- "Kerberos keytab to use for the GSSAPI mechanism. Will use the
- system default (usually /etc/krb5.keytab) if not specified. You may
- need to change the auth service to run as root to be able to read this
- file.")
- (auth-use-winbind?
- (boolean #f)
- "Do NTLM and GSS-SPNEGO authentication using Samba's winbind daemon
- and @samp{ntlm-auth} helper.
- <doc/wiki/Authentication/Mechanisms/Winbind.txt>.")
- (auth-winbind-helper-path
- (file-name "/usr/bin/ntlm_auth")
- "Path for Samba's @samp{ntlm-auth} helper binary.")
- (auth-failure-delay
- (string "2 secs")
- "Time to delay before replying to failed authentications.")
- (auth-ssl-require-client-cert?
- (boolean #f)
- "Require a valid SSL client certificate or the authentication
- fails.")
- (auth-ssl-username-from-cert?
- (boolean #f)
- "Take the username from client's SSL certificate, using
- @code{X509_NAME_get_text_by_NID()} which returns the subject's DN's
- CommonName.")
- (auth-mechanisms
- (space-separated-string-list '("plain"))
- "List of wanted authentication mechanisms. Supported mechanisms are:
- @samp{plain}, @samp{login}, @samp{digest-md5}, @samp{cram-md5},
- @samp{ntlm}, @samp{rpa}, @samp{apop}, @samp{anonymous}, @samp{gssapi},
- @samp{otp}, @samp{skey}, and @samp{gss-spnego}. NOTE: See also
- @samp{disable-plaintext-auth} setting.")
- (director-servers
- (space-separated-string-list '())
- "List of IPs or hostnames to all director servers, including ourself.
- Ports can be specified as ip:port. The default port is the same as what
- director service's @samp{inet-listener} is using.")
- (director-mail-servers
- (space-separated-string-list '())
- "List of IPs or hostnames to all backend mail servers. Ranges are
- allowed too, like 10.0.0.10-10.0.0.30.")
- (director-user-expire
- (string "15 min")
- "How long to redirect users to a specific server after it no longer
- has any connections.")
- (director-username-hash
- (string "%Lu")
- "How the username is translated before being hashed. Useful values
- include %Ln if user can log in with or without @@domain, %Ld if mailboxes
- are shared within domain.")
- ;;; Log destination.
- (log-path
- (string "syslog")
- "Log file to use for error messages. @samp{syslog} logs to syslog,
- @samp{/dev/stderr} logs to stderr.")
- (info-log-path
- (string "")
- "Log file to use for informational messages. Defaults to
- @samp{log-path}.")
- (debug-log-path
- (string "")
- "Log file to use for debug messages. Defaults to
- @samp{info-log-path}.")
- (syslog-facility
- (string "mail")
- "Syslog facility to use if you're logging to syslog. Usually if you
- don't want to use @samp{mail}, you'll use local0..local7. Also other
- standard facilities are supported.")
- (auth-verbose?
- (boolean #f)
- "Log unsuccessful authentication attempts and the reasons why they
- failed.")
- (auth-verbose-passwords
- (string "no")
- "In case of password mismatches, log the attempted password. Valid
- values are no, plain and sha1. sha1 can be useful for detecting brute
- force password attempts vs. user simply trying the same password over
- and over again. You can also truncate the value to n chars by appending
- \":n\" (e.g. sha1:6).")
- (auth-debug?
- (boolean #f)
- "Even more verbose logging for debugging purposes. Shows for example
- SQL queries.")
- (auth-debug-passwords?
- (boolean #f)
- "In case of password mismatches, log the passwords and used scheme so
- the problem can be debugged. Enabling this also enables
- @samp{auth-debug}.")
- (mail-debug?
- (boolean #f)
- "Enable mail process debugging. This can help you figure out why
- Dovecot isn't finding your mails.")
- (verbose-ssl?
- (boolean #f)
- "Show protocol level SSL errors.")
- (log-timestamp
- (string "\"%b %d %H:%M:%S \"")
- "Prefix for each line written to log file. % codes are in
- strftime(3) format.")
- (login-log-format-elements
- (space-separated-string-list
- '("user=<%u>" "method=%m" "rip=%r" "lip=%l" "mpid=%e" "%c"))
- "List of elements we want to log. The elements which have a
- non-empty variable value are joined together to form a comma-separated
- string.")
- (login-log-format
- (string "%$: %s")
- "Login log format. %s contains @samp{login-log-format-elements}
- string, %$ contains the data we want to log.")
- (mail-log-prefix
- (string "\"%s(%u)<%{pid}><%{session}>: \"")
- "Log prefix for mail processes. See doc/wiki/Variables.txt for list
- of possible variables you can use.")
- (deliver-log-format
- (string "msgid=%m: %$")
- "Format to use for logging mail deliveries. You can use variables:
- @table @code
- @item %$
- Delivery status message (e.g. @samp{saved to INBOX})
- @item %m
- Message-ID
- @item %s
- Subject
- @item %f
- From address
- @item %p
- Physical size
- @item %w
- Virtual size.
- @end table")
- ;;; Mailbox locations and namespaces
- (mail-location
- (string "")
- "Location for users' mailboxes. The default is empty, which means
- that Dovecot tries to find the mailboxes automatically. This won't work
- if the user doesn't yet have any mail, so you should explicitly tell
- Dovecot the full location.
- If you're using mbox, giving a path to the INBOX
- file (e.g. /var/mail/%u) isn't enough. You'll also need to tell Dovecot
- where the other mailboxes are kept. This is called the \"root mail
- directory\", and it must be the first path given in the
- @samp{mail-location} setting.
- There are a few special variables you can use, eg.:
- @table @samp
- @item %u
- username
- @item %n
- user part in user@@domain, same as %u if there's no domain
- @item %d
- domain part in user@@domain, empty if there's no domain
- @item %h
- home director
- @end table
- See doc/wiki/Variables.txt for full list. Some examples:
- @table @samp
- @item maildir:~/Maildir
- @item mbox:~/mail:INBOX=/var/mail/%u
- @item mbox:/var/mail/%d/%1n/%n:INDEX=/var/indexes/%d/%1n/%
- @end table")
- (mail-uid
- (string "")
- "System user and group used to access mails. If you use multiple,
- userdb can override these by returning uid or gid fields. You can use
- either numbers or names. <doc/wiki/UserIds.txt>.")
- (mail-gid
- (string "")
- "")
- (mail-privileged-group
- (string "")
- "Group to enable temporarily for privileged operations. Currently
- this is used only with INBOX when either its initial creation or
- dotlocking fails. Typically this is set to \"mail\" to give access to
- /var/mail.")
- (mail-access-groups
- (string "")
- "Grant access to these supplementary groups for mail processes.
- Typically these are used to set up access to shared mailboxes. Note
- that it may be dangerous to set these if users can create
- symlinks (e.g. if \"mail\" group is set here, ln -s /var/mail ~/mail/var
- could allow a user to delete others' mailboxes, or ln -s
- /secret/shared/box ~/mail/mybox would allow reading it).")
- (mail-full-filesystem-access?
- (boolean #f)
- "Allow full file system access to clients. There's no access checks
- other than what the operating system does for the active UID/GID. It
- works with both maildir and mboxes, allowing you to prefix mailboxes
- names with e.g. /path/ or ~user/.")
- ;;; Mail processes
- (mmap-disable?
- (boolean #f)
- "Don't use mmap() at all. This is required if you store indexes to
- shared file systems (NFS or clustered file system).")
- (dotlock-use-excl?
- (boolean #t)
- "Rely on @samp{O_EXCL} to work when creating dotlock files. NFS
- supports @samp{O_EXCL} since version 3, so this should be safe to use
- nowadays by default.")
- (mail-fsync
- (string "optimized")
- "When to use fsync() or fdatasync() calls:
- @table @code
- @item optimized
- Whenever necessary to avoid losing important data
- @item always
- Useful with e.g. NFS when write()s are delayed
- @item never
- Never use it (best performance, but crashes can lose data).
- @end table")
- (mail-nfs-storage?
- (boolean #f)
- "Mail storage exists in NFS. Set this to yes to make Dovecot flush
- NFS caches whenever needed. If you're using only a single mail server
- this isn't needed.")
- (mail-nfs-index?
- (boolean #f)
- "Mail index files also exist in NFS. Setting this to yes requires
- @samp{mmap-disable? #t} and @samp{fsync-disable? #f}.")
- (lock-method
- (string "fcntl")
- "Locking method for index files. Alternatives are fcntl, flock and
- dotlock. Dotlocking uses some tricks which may create more disk I/O
- than other locking methods. NFS users: flock doesn't work, remember to
- change @samp{mmap-disable}.")
- (mail-temp-dir
- (file-name "/tmp")
- "Directory in which LDA/LMTP temporarily stores incoming mails >128
- kB.")
- (first-valid-uid
- (non-negative-integer 500)
- "Valid UID range for users. This is mostly to make sure that users can't
- log in as daemons or other system users. Note that denying root logins is
- hardcoded to dovecot binary and can't be done even if @samp{first-valid-uid}
- is set to 0.")
- (last-valid-uid
- (non-negative-integer 0)
- "")
- (first-valid-gid
- (non-negative-integer 1)
- "Valid GID range for users. Users having non-valid GID as primary group ID
- aren't allowed to log in. If user belongs to supplementary groups with
- non-valid GIDs, those groups are not set.")
- (last-valid-gid
- (non-negative-integer 0)
- "")
- (mail-max-keyword-length
- (non-negative-integer 50)
- "Maximum allowed length for mail keyword name. It's only forced when
- trying to create new keywords.")
- (valid-chroot-dirs
- (colon-separated-file-name-list '())
- "List of directories under which chrooting is allowed for mail
- processes (i.e. /var/mail will allow chrooting to /var/mail/foo/bar
- too). This setting doesn't affect @samp{login-chroot}
- @samp{mail-chroot} or auth chroot settings. If this setting is empty,
- \"/./\" in home dirs are ignored. WARNING: Never add directories here
- which local users can modify, that may lead to root exploit. Usually
- this should be done only if you don't allow shell access for users.
- <doc/wiki/Chrooting.txt>.")
- (mail-chroot
- (string "")
- "Default chroot directory for mail processes. This can be overridden
- for specific users in user database by giving /./ in user's home
- directory (e.g. /home/./user chroots into /home). Note that usually
- there is no real need to do chrooting, Dovecot doesn't allow users to
- access files outside their mail directory anyway. If your home
- directories are prefixed with the chroot directory, append \"/.\" to
- @samp{mail-chroot}. <doc/wiki/Chrooting.txt>.")
- (auth-socket-path
- (file-name "/var/run/dovecot/auth-userdb")
- "UNIX socket path to master authentication server to find users.
- This is used by imap (for shared users) and lda.")
- (mail-plugin-dir
- (file-name "/usr/lib/dovecot")
- "Directory where to look up mail plugins.")
- (mail-plugins
- (space-separated-string-list '())
- "List of plugins to load for all services. Plugins specific to IMAP,
- LDA, etc. are added to this list in their own .conf files.")
- (mail-cache-min-mail-count
- (non-negative-integer 0)
- "The minimum number of mails in a mailbox before updates are done to
- cache file. This allows optimizing Dovecot's behavior to do less disk
- writes at the cost of more disk reads.")
- (mailbox-idle-check-interval
- (string "30 secs")
- "When IDLE command is running, mailbox is checked once in a while to
- see if there are any new mails or other changes. This setting defines
- the minimum time to wait between those checks. Dovecot can also use
- dnotify, inotify and kqueue to find out immediately when changes
- occur.")
- (mail-save-crlf?
- (boolean #f)
- "Save mails with CR+LF instead of plain LF. This makes sending those
- mails take less CPU, especially with sendfile() syscall with Linux and
- FreeBSD. But it also creates a bit more disk I/O which may just make it
- slower. Also note that if other software reads the mboxes/maildirs,
- they may handle the extra CRs wrong and cause problems.")
- (maildir-stat-dirs?
- (boolean #f)
- "By default LIST command returns all entries in maildir beginning
- with a dot. Enabling this option makes Dovecot return only entries
- which are directories. This is done by stat()ing each entry, so it
- causes more disk I/O.
- (For systems setting struct @samp{dirent->d_type} this check is free
- and it's done always regardless of this setting).")
- (maildir-copy-with-hardlinks?
- (boolean #t)
- "When copying a message, do it with hard links whenever possible.
- This makes the performance much better, and it's unlikely to have any
- side effects.")
- (maildir-very-dirty-syncs?
- (boolean #f)
- "Assume Dovecot is the only MUA accessing Maildir: Scan cur/
- directory only when its mtime changes unexpectedly or when we can't find
- the mail otherwise.")
- (mbox-read-locks
- (space-separated-string-list '("fcntl"))
- "Which locking methods to use for locking mbox. There are four
- available:
- @table @code
- @item dotlock
- Create <mailbox>.lock file. This is the oldest and most NFS-safe
- solution. If you want to use /var/mail/ like directory, the users will
- need write access to that directory.
- @item dotlock-try
- Same as dotlock, but if it fails because of permissions or because there
- isn't enough disk space, just skip it.
- @item fcntl
- Use this if possible. Works with NFS too if lockd is used.
- @item flock
- May not exist in all systems. Doesn't work with NFS.
- @item lockf
- May not exist in all systems. Doesn't work with NFS.
- @end table
- You can use multiple locking methods; if you do the order they're declared
- in is important to avoid deadlocks if other MTAs/MUAs are using multiple
- locking methods as well. Some operating systems don't allow using some of
- them simultaneously.")
- (mbox-write-locks
- (space-separated-string-list '("dotlock" "fcntl"))
- "")
- (mbox-lock-timeout
- (string "5 mins")
- "Maximum time to wait for lock (all of them) before aborting.")
- (mbox-dotlock-change-timeout
- (string "2 mins")
- "If dotlock exists but the mailbox isn't modified in any way,
- override the lock file after this much time.")
- (mbox-dirty-syncs?
- (boolean #t)
- "When mbox changes unexpectedly we have to fully read it to find out
- what changed. If the mbox is large this can take a long time. Since
- the change is usually just a newly appended mail, it'd be faster to
- simply read the new mails. If this setting is enabled, Dovecot does
- this but still safely fallbacks to re-reading the whole mbox file
- whenever something in mbox isn't how it's expected to be. The only real
- downside to this setting is that if some other MUA changes message
- flags, Dovecot doesn't notice it immediately. Note that a full sync is
- done with SELECT, EXAMINE, EXPUNGE and CHECK commands.")
- (mbox-very-dirty-syncs?
- (boolean #f)
- "Like @samp{mbox-dirty-syncs}, but don't do full syncs even with SELECT,
- EXAMINE, EXPUNGE or CHECK commands. If this is set,
- @samp{mbox-dirty-syncs} is ignored.")
- (mbox-lazy-writes?
- (boolean #t)
- "Delay writing mbox headers until doing a full write sync (EXPUNGE
- and CHECK commands and when closing the mailbox). This is especially
- useful for POP3 where clients often delete all mails. The downside is
- that our changes aren't immediately visible to other MUAs.")
- (mbox-min-index-size
- (non-negative-integer 0)
- "If mbox size is smaller than this (e.g. 100k), don't write index
- files. If an index file already exists it's still read, just not
- updated.")
- (mdbox-rotate-size
- (non-negative-integer #e10e6)
- "Maximum dbox file size until it's rotated.")
- (mdbox-rotate-interval
- (string "1d")
- "Maximum dbox file age until it's rotated. Typically in days. Day
- begins from midnight, so 1d = today, 2d = yesterday, etc. 0 = check
- disabled.")
- (mdbox-preallocate-space?
- (boolean #f)
- "When creating new mdbox files, immediately preallocate their size to
- @samp{mdbox-rotate-size}. This setting currently works only in Linux
- with some file systems (ext4, xfs).")
- (mail-attribute-dict
- (string "")
- "The location of a dictionary used to store @code{IMAP METADATA}
- as defined by @uref{https://tools.ietf.org/html/rfc5464, RFC@tie{}5464}.
- The IMAP METADATA commands are available only if the ``imap''
- protocol configuration's @code{imap-metadata?} field is @samp{#t}.")
- (mail-attachment-dir
- (string "")
- "sdbox and mdbox support saving mail attachments to external files,
- which also allows single instance storage for them. Other backends
- don't support this for now.
- WARNING: This feature hasn't been tested much yet. Use at your own risk.
- Directory root where to store mail attachments. Disabled, if empty.")
- (mail-attachment-min-size
- (non-negative-integer #e128e3)
- "Attachments smaller than this aren't saved externally. It's also
- possible to write a plugin to disable saving specific attachments
- externally.")
- (mail-attachment-fs
- (string "sis posix")
- "File system backend to use for saving attachments:
- @table @code
- @item posix
- No SiS done by Dovecot (but this might help FS's own deduplication)
- @item sis posix
- SiS with immediate byte-by-byte comparison during saving
- @item sis-queue posix
- SiS with delayed comparison and deduplication.
- @end table")
- (mail-attachment-hash
- (string "%{sha1}")
- "Hash format to use in attachment filenames. You can add any text and
- variables: @code{%@{md4@}}, @code{%@{md5@}}, @code{%@{sha1@}},
- @code{%@{sha256@}}, @code{%@{sha512@}}, @code{%@{size@}}. Variables can be
- truncated, e.g. @code{%@{sha256:80@}} returns only first 80 bits.")
- (default-process-limit
- (non-negative-integer 100)
- "")
- (default-client-limit
- (non-negative-integer 1000)
- "")
- (default-vsz-limit
- (non-negative-integer #e256e6)
- "Default VSZ (virtual memory size) limit for service processes.
- This is mainly intended to catch and kill processes that leak memory
- before they eat up everything.")
- (default-login-user
- (string "dovenull")
- "Login user is internally used by login processes. This is the most
- untrusted user in Dovecot system. It shouldn't have access to anything
- at all.")
- (default-internal-user
- (string "dovecot")
- "Internal user is used by unprivileged processes. It should be
- separate from login user, so that login processes can't disturb other
- processes.")
- (ssl?
- (string "required")
- "SSL/TLS support: yes, no, required. <doc/wiki/SSL.txt>.")
- (ssl-cert
- (string "</etc/dovecot/default.pem")
- "PEM encoded X.509 SSL/TLS certificate (public key).")
- (ssl-key
- (string "</etc/dovecot/private/default.pem")
- "PEM encoded SSL/TLS private key. The key is opened before
- dropping root privileges, so keep the key file unreadable by anyone but
- root.")
- (ssl-key-password
- (string "")
- "If key file is password protected, give the password here.
- Alternatively give it when starting dovecot with -p parameter. Since
- this file is often world-readable, you may want to place this setting
- instead to a different.")
- (ssl-ca
- (string "")
- "PEM encoded trusted certificate authority. Set this only if you
- intend to use @samp{ssl-verify-client-cert? #t}. The file should
- contain the CA certificate(s) followed by the matching
- CRL(s). (e.g. @samp{ssl-ca </etc/ssl/certs/ca.pem}).")
- (ssl-require-crl?
- (boolean #t)
- "Require that CRL check succeeds for client certificates.")
- (ssl-verify-client-cert?
- (boolean #f)
- "Request client to send a certificate. If you also want to require
- it, set @samp{auth-ssl-require-client-cert? #t} in auth section.")
- (ssl-cert-username-field
- (string "commonName")
- "Which field from certificate to use for username. commonName and
- x500UniqueIdentifier are the usual choices. You'll also need to set
- @samp{auth-ssl-username-from-cert? #t}.")
- (ssl-min-protocol
- (string "TLSv1")
- "Minimum SSL protocol version to accept.")
- (ssl-cipher-list
- (string "ALL:!kRSA:!SRP:!kDHd:!DSS:!aNULL:!eNULL:!EXPORT:!DES:!3DES:!MD5:!PSK:!RC4:!ADH:!LOW@STRENGTH")
- "SSL ciphers to use.")
- (ssl-crypto-device
- (string "")
- "SSL crypto device to use, for valid values run \"openssl engine\".")
- (postmaster-address
- (string "postmaster@%d")
- "Address to use when sending rejection mails.
- Default is postmaster@@<your domain>. %d expands to recipient domain.")
- (hostname
- (string "")
- "Hostname to use in various parts of sent mails (e.g. in Message-Id)
- and in LMTP replies. Default is the system's real hostname@@domain.")
- (quota-full-tempfail?
- (boolean #f)
- "If user is over quota, return with temporary failure instead of
- bouncing the mail.")
- (sendmail-path
- (file-name "/usr/sbin/sendmail")
- "Binary to use for sending mails.")
- (submission-host
- (string "")
- "If non-empty, send mails via this SMTP host[:port] instead of
- sendmail.")
- (rejection-subject
- (string "Rejected: %s")
- "Subject: header to use for rejection mails. You can use the same
- variables as for @samp{rejection-reason} below.")
- (rejection-reason
- (string "Your message to <%t> was automatically rejected:%n%r")
- "Human readable error message for rejection mails. You can use
- variables:
- @table @code
- @item %n
- CRLF
- @item %r
- reason
- @item %s
- original subject
- @item %t
- recipient
- @end table")
- (recipient-delimiter
- (string "+")
- "Delimiter character between local-part and detail in email
- address.")
- (lda-original-recipient-header
- (string "")
- "Header where the original recipient address (SMTP's RCPT TO:
- address) is taken from if not available elsewhere. With dovecot-lda -a
- parameter overrides this. A commonly used header for this is
- X-Original-To.")
- (lda-mailbox-autocreate?
- (boolean #f)
- "Should saving a mail to a nonexistent mailbox automatically create
- it?.")
- (lda-mailbox-autosubscribe?
- (boolean #f)
- "Should automatically created mailboxes be also automatically
- subscribed?.")
- (imap-max-line-length
- (non-negative-integer #e64e3)
- "Maximum IMAP command line length. Some clients generate very long
- command lines with huge mailboxes, so you may need to raise this if you
- get \"Too long argument\" or \"IMAP command line too large\" errors
- often.")
- (imap-logout-format
- (string "in=%i out=%o deleted=%{deleted} expunged=%{expunged} trashed=%{trashed} hdr_count=%{fetch_hdr_count} hdr_bytes=%{fetch_hdr_bytes} body_count=%{fetch_body_count} body_bytes=%{fetch_body_bytes}")
- "IMAP logout format string:
- @table @code
- @item %i
- total number of bytes read from client
- @item %o
- total number of bytes sent to client.
- @end table
- See @file{doc/wiki/Variables.txt} for a list of all the variables you can use.")
- (imap-capability
- (string "")
- "Override the IMAP CAPABILITY response. If the value begins with '+',
- add the given capabilities on top of the defaults (e.g. +XFOO XBAR).")
- (imap-idle-notify-interval
- (string "2 mins")
- "How long to wait between \"OK Still here\" notifications when client
- is IDLEing.")
- (imap-id-send
- (string "")
- "ID field names and values to send to clients. Using * as the value
- makes Dovecot use the default value. The following fields have default
- values currently: name, version, os, os-version, support-url,
- support-email.")
- (imap-id-log
- (string "")
- "ID fields sent by client to log. * means everything.")
- (imap-client-workarounds
- (space-separated-string-list '())
- "Workarounds for various client bugs:
- @table @code
- @item delay-newmail
- Send EXISTS/RECENT new mail notifications only when replying to NOOP and
- CHECK commands. Some clients ignore them otherwise, for example OSX
- Mail (<v2.1). Outlook Express breaks more badly though, without this it
- may show user \"Message no longer in server\" errors. Note that OE6
- still breaks even with this workaround if synchronization is set to
- \"Headers Only\".
- @item tb-extra-mailbox-sep
- Thunderbird gets somehow confused with LAYOUT=fs (mbox and dbox) and
- adds extra @samp{/} suffixes to mailbox names. This option causes Dovecot to
- ignore the extra @samp{/} instead of treating it as invalid mailbox name.
- @item tb-lsub-flags
- Show \\Noselect flags for LSUB replies with LAYOUT=fs (e.g. mbox).
- This makes Thunderbird realize they aren't selectable and show them
- greyed out, instead of only later giving \"not selectable\" popup error.
- @end table
- ")
- (imap-urlauth-host
- (string "")
- "Host allowed in URLAUTH URLs sent by client. \"*\" allows all.")
- (protocols
- (protocol-configuration-list
- (list (protocol-configuration
- (name "imap"))))
- "List of protocols we want to serve. Available protocols include
- @samp{imap}, @samp{pop3}, and @samp{lmtp}.")
- (services
- (service-configuration-list
- (list
- (service-configuration
- (kind "imap-login")
- (client-limit 0)
- (process-limit 0)
- (listeners
- (list
- (inet-listener-configuration (protocol "imap") (port 143) (ssl? #f))
- (inet-listener-configuration (protocol "imaps") (port 993) (ssl? #t)))))
- (service-configuration
- (kind "pop3-login")
- (listeners
- (list
- (inet-listener-configuration (protocol "pop3") (port 110) (ssl? #f))
- (inet-listener-configuration (protocol "pop3s") (port 995) (ssl? #t)))))
- (service-configuration
- (kind "lmtp")
- (client-limit 1)
- (process-limit 0)
- (listeners
- (list (unix-listener-configuration (path "lmtp") (mode "0666")))))
- (service-configuration
- (kind "imap")
- (client-limit 1)
- (process-limit 1024))
- (service-configuration
- (kind "pop3")
- (client-limit 1)
- (process-limit 1024))
- (service-configuration
- (kind "auth")
- (service-count 0)
- (client-limit 0)
- (process-limit 1)
- (listeners
- (list (unix-listener-configuration (path "auth-userdb")))))
- (service-configuration
- (kind "auth-worker")
- (client-limit 1)
- (process-limit 0))
- (service-configuration
- (kind "dict")
- (client-limit 1)
- (process-limit 0)
- (listeners (list (unix-listener-configuration (path "dict")))))))
- "List of services to enable. Available services include @samp{imap},
- @samp{imap-login}, @samp{pop3}, @samp{pop3-login}, @samp{auth}, and
- @samp{lmtp}."))
- (define-configuration opaque-dovecot-configuration
- (dovecot
- (file-like dovecot)
- "The dovecot package.")
- (string
- (string (configuration-missing-field 'opaque-dovecot-configuration
- 'string))
- "The contents of the @code{dovecot.conf} to use."))
- (define %dovecot-accounts
- ;; Account and group for the Dovecot daemon.
- (list (user-group (name "dovecot") (system? #t))
- (user-account
- (name "dovecot")
- (group "dovecot")
- (system? #t)
- (comment "Dovecot daemon user")
- (home-directory "/var/empty")
- (shell (file-append shadow "/sbin/nologin")))
- (user-group (name "dovenull") (system? #t))
- (user-account
- (name "dovenull")
- (group "dovenull")
- (system? #t)
- (comment "Dovecot daemon login user")
- (home-directory "/var/empty")
- (shell (file-append shadow "/sbin/nologin")))))
- (define (%dovecot-activation config)
- ;; Activation gexp.
- (let ((config-str
- (cond
- ((opaque-dovecot-configuration? config)
- (opaque-dovecot-configuration-string config))
- (else
- (with-output-to-string
- (lambda ()
- (serialize-configuration config
- dovecot-configuration-fields)))))))
- #~(begin
- (use-modules (guix build utils))
- (define (mkdir-p/perms directory owner perms)
- (mkdir-p directory)
- (chown "/var/run/dovecot" (passwd:uid owner) (passwd:gid owner))
- (chmod directory perms))
- (define (build-subject parameters)
- (string-concatenate
- (map (lambda (pair)
- (let ((k (car pair)) (v (cdr pair)))
- (define (escape-char str chr)
- (string-join (string-split str chr) (string #\\ chr)))
- (string-append "/" k "="
- (escape-char (escape-char v #\=) #\/))))
- (filter (lambda (pair) (cdr pair)) parameters))))
- (define* (create-self-signed-certificate-if-absent
- #:key private-key public-key (owner (getpwnam "root"))
- (common-name (gethostname))
- (organization-name "Guix")
- (organization-unit-name "Default Self-Signed Certificate")
- (subject-parameters `(("CN" . ,common-name)
- ("O" . ,organization-name)
- ("OU" . ,organization-unit-name)))
- (subject (build-subject subject-parameters)))
- ;; Note that by default, OpenSSL outputs keys in PEM format. This
- ;; is what we want.
- (unless (file-exists? private-key)
- (cond
- ((zero? (system* (string-append #$openssl "/bin/openssl")
- "genrsa" "-out" private-key "2048"))
- (chown private-key (passwd:uid owner) (passwd:gid owner))
- (chmod private-key #o400))
- (else
- (format (current-error-port)
- "Failed to create private key at ~a.\n" private-key))))
- (unless (file-exists? public-key)
- (cond
- ((zero? (system* (string-append #$openssl "/bin/openssl")
- "req" "-new" "-x509" "-key" private-key
- "-out" public-key "-days" "3650"
- "-batch" "-subj" subject))
- (chown public-key (passwd:uid owner) (passwd:gid owner))
- (chmod public-key #o444))
- (else
- (format (current-error-port)
- "Failed to create public key at ~a.\n" public-key)))))
- (let ((user (getpwnam "dovecot")))
- (mkdir-p/perms "/var/run/dovecot" user #o755)
- (mkdir-p/perms "/var/lib/dovecot" user #o755)
- (mkdir-p/perms "/etc/dovecot" user #o755)
- (copy-file #$(plain-file "dovecot.conf" config-str)
- "/etc/dovecot/dovecot.conf")
- (mkdir-p/perms "/etc/dovecot/private" user #o700)
- (create-self-signed-certificate-if-absent
- #:private-key "/etc/dovecot/private/default.pem"
- #:public-key "/etc/dovecot/default.pem"
- #:owner (getpwnam "root")
- #:common-name (format #f "Dovecot service on ~a" (gethostname)))))))
- (define (dovecot-shepherd-service config)
- "Return a list of <shepherd-service> for CONFIG."
- (let ((dovecot (if (opaque-dovecot-configuration? config)
- (opaque-dovecot-configuration-dovecot config)
- (dovecot-configuration-dovecot config))))
- (list (shepherd-service
- (documentation "Run the Dovecot POP3/IMAP mail server.")
- (provision '(dovecot))
- (requirement '(networking))
- (start #~(make-forkexec-constructor
- (list (string-append #$dovecot "/sbin/dovecot")
- "-F")))
- (stop #~(lambda _
- (invoke #$(file-append dovecot "/sbin/dovecot")
- "stop")
- #f))))))
- (define %dovecot-pam-services
- (list (unix-pam-service "dovecot")))
- (define dovecot-service-type
- (service-type (name 'dovecot)
- (extensions
- (list (service-extension shepherd-root-service-type
- dovecot-shepherd-service)
- (service-extension account-service-type
- (const %dovecot-accounts))
- (service-extension pam-root-service-type
- (const %dovecot-pam-services))
- (service-extension activation-service-type
- %dovecot-activation)))
- (description "Run Dovecot, a mail server that can run POP3,
- IMAP, and LMTP.")))
- (define* (dovecot-service #:key (config (dovecot-configuration)))
- "Return a service that runs @command{dovecot}, a mail server that can run
- POP3, IMAP, and LMTP. @var{config} should be a configuration object created
- by @code{dovecot-configuration}. @var{config} may also be created by
- @code{opaque-dovecot-configuration}, which allows specification of the
- @code{dovecot.conf} as a string."
- (service dovecot-service-type config))
- ;; A little helper to make it easier to document all those fields.
- (define (generate-dovecot-documentation)
- (generate-documentation
- `((dovecot-configuration
- ,dovecot-configuration-fields
- (dict dict-configuration)
- (namespaces namespace-configuration)
- (plugin plugin-configuration)
- (passdbs passdb-configuration)
- (userdbs userdb-configuration)
- (services service-configuration)
- (protocols protocol-configuration))
- (dict-configuration ,dict-configuration-fields)
- (plugin-configuration ,plugin-configuration-fields)
- (passdb-configuration ,passdb-configuration-fields)
- (userdb-configuration ,userdb-configuration-fields)
- (unix-listener-configuration ,unix-listener-configuration-fields)
- (fifo-listener-configuration ,fifo-listener-configuration-fields)
- (inet-listener-configuration ,inet-listener-configuration-fields)
- (namespace-configuration
- ,namespace-configuration-fields
- (mailboxes mailbox-configuration))
- (mailbox-configuration ,mailbox-configuration-fields)
- (service-configuration
- ,service-configuration-fields
- (listeners unix-listener-configuration fifo-listener-configuration
- inet-listener-configuration))
- (protocol-configuration ,protocol-configuration-fields))
- 'dovecot-configuration))
- ;;; OpenSMTPD.
- ;;;
- ;;; This next bit of code helps me create my own sanitizer functions.
- ;; some fieldnames have a default value of #f, which is ok. They cannot have
- ;; a value of #t.
- ;; for example opensmtpd-table-data 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? var)
- (eq? #f var))
- ;; TODO I have to have this procedure, or I need to change my/sanitize
- ;; procedure.
- (define (my-file-exists? file)
- (and (string? file)
- (access? file F_OK)))
- ;; This procedure takes in a var and a list of procedures. It loops through
- ;; list of procedures passing in var to each.
- ;; if one procedure returns #t, the function returns true. Otherwise #f.
- ;; TODO for fun rewrite this using map
- ;; If I rewrote it in map, then it may help with sanitizing.
- ;; eg: I could then potentially easily sanitize vars with lambda procedures.
- (define (is-value-right-type? var list-of-procedures record fieldname)
- (if (null? list-of-procedures)
- #f
- (if ((car list-of-procedures) var)
- #t
- (is-value-right-type? var (cdr list-of-procedures) record
- fieldname))))
- ;; 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))
- (define (list-of-procedures->string procedures)
- (define string
- (let loop ((procedures procedures))
- (if (null? procedures)
- ""
- (begin
- (string-append
- (cond ((eq? false? (car procedures))
- "#f, ")
- ((eq? boolean? (car procedures))
- "a boolean, ")
- ((eq? string? (car procedures))
- "a string, ")
- ((eq? integer? (car procedures))
- "an integer, ")
- ((eq? list-of-strings? (car procedures))
- "a list of strings, ")
- ((eq? assoc-list? (car procedures))
- "an association list of strings, ")
- ((eq? nested-list? (car procedures))
- "a nested-list of strings, ")
- ((eq? opensmtpd-pki? (car procedures))
- "an <opensmtpd-pki> record, ")
- ((eq? opensmtpd-table? (car procedures))
- "an <opensmtpd-table> record, ")
- ((eq? list-of-opensmtpd-match? (car procedures))
- "a list of unique <opensmtpd-match> records, ")
- ((eq? list-of-strings-or-gexps? (car procedures))
- "a list of strings or gexps, ")
- ;; TODO can I remove the next two procedures?
- ;; tables-data-are-a* ? I think I can.
- ((eq? tables-data-are-assoc-list? (car procedures))
- (string-append
- "an <opensmtpd-table> record whose fieldname 'data' are "
- "an assoc-list.\nFor example: (opensmtpd-table "
- "(name \"hostnames\") , "
- "(data '((\"124.394.23.1\" . \"gnu.org\"))))"))
- ((eq? tables-data-are-a-list-of-strings?
- (car procedures))
- (string-append
- "on <opensmtpd-table> record whose fieldname 'data' is "
- "a list of strings.\n"
- "For example: (opensmtpd-table (name \"domains\") , "
- "(data (list \"gnu.org\" \"guix.gnu.org\")))"))
- ((eq? my-file-exists? (car procedures))
- "a file, ")
- (else "has an incorrect value, "))
- (loop (cdr procedures)))))))
- (add-comma-or (string-append (string-drop-right string 2) ".\n")))
- (define (list-of-strings-or-gexps? list)
- (and (list? list)
- (cond ((null? list)
- #t)
- ((or (string? (car list))
- (gexp? (car list))
- (local-file? (car list))
- (file-append? (car list))
- (plain-file? (car list))
- (computed-file? (car list))
- (program-file? (car list)))
- (list-of-strings-or-gexps? (cdr list)))
- (else #f))))
- (define (my/sanitize var record fieldname list-of-procedures)
- (define try-string
- (string-append "Try " (list-of-procedures->string list-of-procedures)))
- (if (is-value-right-type? var list-of-procedures record fieldname)
- var
- (begin
- (cond ((string? var)
- (report-error (G_ "(~a \"~a\") is invalid.~%") fieldname var))
- ((or (number? var) (boolean? var))
- (report-error (G_ "(~a ~a) is invalid.~%") fieldname var) )
- (else
- (report-error (G_ "(~a ...) is invalid.~%Value is: ~a~%")
- fieldname var)))
- (display-hint (G_ try-string))
- (throw 'bad! var))))
- ;;; The Opensmtpd records.
- ;; Some example opensmtpd-tables:
- ;;
- ;; (opensmtpd-table (name "root accounts")
- ;; (data '(("joshua" . "root@dismail.de")
- ;; ("joshua" . "postmaster@dismail.de"))))
- ;; (opensmtpd-table (name "root accounts")
- ;; (data (list "mysite.me" "your-site.com")))
- ;; TODO: How am I supporting file: or db: tables?
- ;; Perhaps I should just automatically convert the table to a database table
- ;; if the data gets large enough. What would be sufficently large enough?
- (define-record-type* <opensmtpd-table>
- opensmtpd-table make-opensmtpd-table
- opensmtpd-table?
- (name opensmtpd-table-name ;; string
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-table" "name"
- (list string?)))))
- ;; 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 }
- ;; If values is an absolute filename, then it will use said filename to
- ;; house the table info. filename must be an absolute filename.
- (data opensmtpd-table-data
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-table" "data"
- (list list-of-strings? assoc-list?
- nested-list?))))))
- (define-record-type* <opensmtpd-ca>
- opensmtpd-ca make-opensmtpd-ca
- opensmtpd-ca?
- (name opensmtpd-ca-name
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-ca" "name" (list string?)))))
- (file opensmtpd-ca-file
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-ca" "file"
- (list my-file-exists?))))))
- (define-record-type* <opensmtpd-pki>
- opensmtpd-pki make-opensmtpd-pki
- opensmtpd-pki?
- (domain opensmtpd-pki-domain
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-pki" "domain"
- (list string?)))))
- ;; TODO/FIXME this should probably be a list of files. The opensmtpd
- ;; documentation says that you could have a list of files:
- ;;
- ;; pki pkiname cert certfile
- ;; Associate certificate file certfile with host pkiname, and use that file
- ;; to prove the identity of the mail server to clients. pkiname is the
- ;; server's name, derived from the default hostname or set using either
- ;; /gnu/store/2d13sdz76ldq8zgwv4wif0zx7hkr3mh2-opensmtpd-6.8.0p2/etc/mailname
- ;; or using the hostname directive. If a fallback certificate or SNI is
- ;; wanted, the ‘*’ wildcard may be used as pkiname.
- ;; A certificate chain may be created by appending one or many certificates,
- ;; including a Certificate Authority certificate, to certfile. The creation
- ;; of certificates is documented in starttls(8).
- (cert opensmtpd-pki-cert
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-pki" "cert"
- (list my-file-exists?)))))
- (key opensmtpd-pki-key
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-pki" "key"
- (list my-file-exists?)))))
- ; todo sanitize this. valid parameters are "none", "legacy", or "auto".
- (dhe opensmtpd-pki-dhe
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-dhe" "dhe"
- (list false? string?))))))
- (define-record-type* <opensmtpd-lmtp>
- opensmtpd-lmtp make-opensmtpd-lmtp
- opensmtpd-lmtp?
- (destination opensmtpd-lmtp-destination
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-lmtp" "destination"
- (list string?)))))
- (rcpt-to opensmtpd-lmtp-rcpt-to
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-lmtp" "rcpt-to"
- (list false? string?))))))
- (define-record-type* <opensmtpd-mda>
- opensmtpd-mda make-opensmtpd-mda
- opensmtpd-mda?
- (name opensmtpd-mda-name
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-mda" "name"
- (list string?)))))
- ;; TODO should I allow this command to be a gexp?
- (command opensmtpd-mda-command
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-mda" "command"
- (list string?))))))
- (define-record-type* <opensmtpd-maildir>
- opensmtpd-maildir make-opensmtpd-maildir
- opensmtpd-maildir?
- (pathname opensmtpd-maildir-pathname
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-maildir" "pathname"
- (list false? string?)))))
- (junk opensmtpd-maildir-junk
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-maildir" "junk"
- (list boolean?))))))
- (define-record-type* <opensmtpd-local-delivery>
- opensmtpd-local-delivery make-opensmtpd-local-delivery
- opensmtpd-local-delivery?
- (name opensmtpd-local-delivery-name
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-local-delivery" "name"
- (list string?)))))
- (method opensmtpd-local-delivery-method
- (default "mbox")
- (sanitize (lambda (var)
- (define fieldname "method")
- (define options (list "mbox" "expand-only"
- "forward-only"))
- (define options-plus-records
- (append options (list "(opensmtpd-lmtp ...)"
- "(opensmtpd-maildir ...)"
- "(opensmtpd-mda ...)")))
- (cond ((or (opensmtpd-lmtp? var)
- (opensmtpd-maildir? var)
- (opensmtpd-mda? var)
- (member var options))
- var)
- (else
- (begin
- (report-error (G_ "(~a \"~a\") is invalid.~%")
- fieldname var)
- (display-hint
- (G_ (hint-string
- var
- options-plus-records
- #:fieldname fieldname)))
- (throw 'bad! var)))))))
- (alias opensmtpd-local-delivery-alias
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-local-delivery" "alias"
- (list false?
- tables-data-are-assoc-list?)))))
- (ttl opensmtpd-local-delivery-ttl
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-local-delivery" "ttl"
- (list false? string?)))))
- (user opensmtpd-local-delivery-user
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-local-delivery" "user"
- (list false? string?)))))
- (userbase opensmtpd-local-delivery-userbase
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-local-delivery" "userbase"
- (list false?
- tables-data-are-assoc-list?)))))
- (virtual opensmtpd-local-delivery-virtual
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-local-delivery" "virtual"
- (list
- false?
- tables-data-are-assoc-list?)))))
- (wrapper opensmtpd-local-delivery-wrapper
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-local-delivery" "wrapper"
- (list false? string?))))))
- (define-record-type* <opensmtpd-relay>
- opensmtpd-relay make-opensmtpd-relay
- opensmtpd-relay?
- (name opensmtpd-relay-name
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-relay" "name"
- (list string?))))
- (default #f))
- (backup opensmtpd-relay-backup ;; boolean
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-relay" "backup"
- (list boolean?)))))
- (backup-mx opensmtpd-relay-backup-mx ;; string mx name
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-relay" "backup-mx"
- (list false? string?)))))
- (helo opensmtpd-relay-helo
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-relay" "helo"
- (list false? string?))))
- (default #f))
- (helo-src opensmtpd-relay-helo-src
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-relay" "helo-src"
- (list false? string?
- tables-data-are-assoc-list?))))
- (default #f))
- (domain opensmtpd-relay-domain
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-relay" "domain"
- (list false? opensmtpd-table?))))
- (default #f))
- (host opensmtpd-relay-host
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-relay" "host"
- (list false? string?))))
- (default #f))
- (pki opensmtpd-relay-pki
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-relay" "pki"
- (list false? opensmtpd-pki?)))))
- (srs opensmtpd-relay-srs
- (default #f)
- (lambda (var)
- (my/sanitize var "opensmtpd-relay" "srs"
- (list boolean?))))
- (tls opensmtpd-relay-tls
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-relay" "tls"
- (list false? string?)))))
- ;; the table here looks like:
- ;; label1 user:password
- ;; label2 user2:password2
- ;; It is documented in the credentials table in man table
- (auth opensmtpd-relay-auth
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-relay" "auth"
- (list false?
- tables-data-are-assoc-list?))))
- (default #f))
- (mail-from opensmtpd-relay-mail-from
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-relay" "mail-from"
- (list false? string?))))
- (default #f))
- ;; string "127.0.0.1" or "<interface>" or "<table of IP addresses>"
- ;; TODO should I do some sanitizing to make sure that the string?
- ;; here is actually an IP address or a valid interface?
- (src opensmtpd-relay-src
- (sanitize
- (lambda (var)
- (my/sanitize var "opensmtpd-relay" "src"
- (list false? string?
- tables-data-are-a-list-of-strings?))))
- (default #f)))
- ;; this record is used by <opensmtpd-filter-phase> &
- ;; <opensmtpd-match>
- (define-record-type* <opensmtpd-option>
- opensmtpd-option make-opensmtpd-option
- opensmtpd-option?
- (option opensmtpd-option-option
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-option" "option"
- (list string?)))))
- (bool opensmtpd-option-bool
- (default #t)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-option" "not"
- (list boolean?)))))
- (regex opensmtpd-option-regex
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-option" "regex"
- (list boolean?)))))
- (data opensmtpd-option-data
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-option" "data"
- (list false? string? opensmtpd-table?))))))
- (define-record-type* <opensmtpd-filter-phase>
- opensmtpd-filter-phase make-opensmtpd-filter-phase
- opensmtpd-filter-phase?
- (name opensmtpd-filter-phase-name ;; string
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-filter-phase" "name"
- (list string?)))))
- (phase opensmtpd-filter-phase-phase ;; string
- (default #f)
- (sanitize
- (lambda (var)
- (define options
- (list "connect" "helo" "ehlo" "mail-from"
- "rcpt-to" "data" "commit"))
- (define fieldname "phase")
- (if (and (string? var)
- (member var options))
- var
- (begin
- (report-error
- (G_
- "(opensmtpd-filter-phase ... (~a \"~a\")) is invalid.~%")
- fieldname var)
- (display-hint
- (G_ (hint-string var options
- #:fieldname fieldname)))
- (throw 'bad! var))))))
- (options opensmtpd-filter-phase-options
- (default #f)
- (sanitize
- (lambda (var)
- (cond
- ((false? var)
- (report-error (G_ ""))
- (display "(opensmtpd-filter-phase (options #f)) is invalid.\n")
- (display-hint
- (G_ "Try a list of (opensmtpd-option) records.\n"))
- (throw 'bad! #f))
- ((not (list-of-opensmtpd-option? var))
- (report-error (G_ ""))
- (display "(opensmtpd-filter-phase (options ...) is invalid.\n")
- (display-hint
- (G_ "Try a list of (opensmtpd-option) records.\n"))
- (throw 'bad! var))
- (else (sanitize-options-for-filter-phase var))))))
- (decision opensmtpd-filter-phase-decision
- (default #f)
- (sanitize
- (lambda (var)
- (define options
- (list "bypass" "disconnect"
- "reject" "rewrite" "junk"))
- (define fieldname "decision")
- (if (and (string? var)
- (member var options))
- var
- (begin
- (report-error (G_ "(~a \"~a\") is invalid.~%")
- fieldname var)
- (display-hint (G_ (hint-string var options
- #:fieldname fieldname)))
- (throw 'bad! var))))))
- (message opensmtpd-filter-phase-message
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-filter-phase" "message"
- (list false? string?)))))
- (value opensmtpd-filter-phase-value
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-filter-phase" "value"
- (list false? number?))))))
- (define-record-type* <opensmtpd-filter>
- opensmtpd-filter make-opensmtpd-filter
- opensmtpd-filter?
- (name opensmtpd-filter-name
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-filter" "name"
- (list string?)))))
- (exec opensmtpd-filter-exec
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-filter" "exec"
- (list boolean?)))))
- ;; a string like "rspamd" or the command to start it like
- ;; "/path/to/rspamd --option=arg --2nd-option=arg2"
- ;; OR a list of strings and/or geps.
- (proc opensmtpd-filter-proc
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-filter" "proc"
- (list string?
- list-of-strings-or-gexps?))))))
- ;; There is another type of filter that opensmtpd supports, which is a
- ;; filter chain. A filter chain is a list of <opensmtpd-filter-phase>s
- ;; and/or <opensmtpd-filter>s. This lets you apply several filters under
- ;; one filter name. I could have defined a record type for it, but the
- ;; record would only have had two fields: name and list-of-filters.
- ;; Why write that as a record? It makes the user of this service harder.
- ;; Instead, just define it as a list, and if a user wants an interface
- ;; to make multiple filters, he just appends to the 'filters' fieldname.
- ;;
- ;; returns #t if list is a unique list of <opensmtpd-filter> or
- ;; <opensmtpd-filter-phase>
- ;; returns # otherwise
- (define (opensmtpd-filter-chain? %filters)
- (and (list-of-unique-filter-or-filter-phase? %filters)
- (< 1 (length %filters))))
- (define-record-type* <opensmtpd-interface>
- opensmtpd-interface make-opensmtpd-interface
- opensmtpd-interface?
- ;; interface may be an IP address, interface group, or domain name
- (interface opensmtpd-interface-interface
- (default "lo")
- (sanitize (lambda (var)
- (my/sanitize var "interface" "interface"
- (list string?)))))
- (family opensmtpd-interface-family
- (default #f)
- (sanitize
- (lambda (var)
- (define options (list "inet4" "inet6"))
- (define fieldname "family")
- (cond
- ((eq? #f var) ;; var == #f
- var)
- ((and (string? var)
- (member var options))
- var)
- (else
- (begin
- (report-error (G_ "(~a \"~a\") is invalid.~%") fieldname var)
- (display-hint (G_ (hint-string var options
- #:fieldname fieldname)))
- (throw 'bad! var)))))))
- (auth opensmtpd-interface-auth
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-interface" "auth"
- (list boolean?
- tables-data-are-assoc-list?)))))
- (auth-optional opensmtpd-interface-auth-optional
- (default #f)
- (sanitize
- (lambda (var)
- (my/sanitize var "opensmtpd-interface" "auth-optional"
- (list boolean?
- tables-data-are-assoc-list?)))))
- ;; TODO add a ca entry?
- ;; string FIXME/TODO sanitize this to support a gexp. That way way the
- ;; includes directive can include my hacky scheme code that I use
- ;; for opensmtpd-dkimsign.
- (filters opensmtpd-interface-filters
- (default #f)
- (sanitize (lambda (var)
- (sanitize-socket-and-interfaces-filters var))))
- (hostname opensmtpd-interface-hostname
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-interface" "hostname"
- (list false? string?)))))
- (hostnames opensmtpd-interface-hostnames
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-interface" "hostnames"
- (list
- false?
- tables-data-are-assoc-list?)))))
- (mask-src opensmtpd-interface-mask-src
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-interface" "mask-src"
- (list boolean?)))))
- (disable-dsn opensmtpd-interface-disable-dsn
- (default #f))
- (pki opensmtpd-interface-pki
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-interface" "pki"
- (list false? opensmtpd-pki?)))))
- (port opensmtpd-interface-port
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-interface" "port"
- (list false? integer?)))))
- (proxy-v2 opensmtpd-interface-proxy-k2
- (default #f))
- (received-auth opensmtpd-interface-received-auth
- (default #f))
- (senders opensmtpd-interface-senders
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-interface" "senders"
- (list false?
- tables-data-are-assoc-list?))))
- (default #f))
- (masquerade opensmtpd-interface-masquerade
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-interface" "masquerade"
- (list boolean?))))
- (default #f))
- (secure-connection opensmtpd-interface-secure-connection
- (default #f)
- (sanitize
- (lambda (var)
- (define options
- (list "smtps" "tls" "tls-require"
- "tls-require-verify"))
- (define fieldname "secure-connection")
- (cond ((boolean? var)
- var)
- ((and (string? var)
- (member var options))
- var)
- (else
- (begin
- (report-error
- (G_ "(~a \"~a\") is invalid.~%")
- fieldname var)
- (display-hint
- (G_ (hint-string var options
- #:fieldname fieldname)))
- (throw 'bad! var)))))))
- (tag opensmtpd-interface-tag
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-interface" "tag"
- (list false? string?))))
- (default #f)))
- (define-record-type* <opensmtpd-socket>
- opensmtpd-socket make-opensmtpd-socket
- opensmtpd-socket?
- ;; false or <opensmtpd-filter> or list of <opensmtpd-filter>
- (filters opensmtpd-socket-filters
- (sanitize (lambda (var)
- (sanitize-socket-and-interfaces-filters
- var
- #:socket-or-interface "socket")))
- (default #f))
- (mask-src opensmtpd-socket-mask-src
- (default #f)
- (my/sanitize var "opensmtpd-interface" "mask-src"
- (list false? boolean?)))
- (tag opensmtpd-socket-tag
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-interface" "tag"
- (list false? string?))))
- (default #f)))
- (define-record-type* <opensmtpd-match>
- opensmtpd-match make-opensmtpd-match
- opensmtpd-match?
- ;;TODO? Perhaps I should add in a reject fieldname. If reject
- ;;is #t, then the match record will be a reject match record.
- ;; (opensmtpd-match (reject #t)) vs. (opensmtpd-match (action 'reject))
- ;; To do this, I will also have to 'reject' mutually exclusive.
- ;; AND an match with 'reject' can have no action defined.
- (action opensmtpd-match-action
- (default #f)
- (sanitize
- (lambda (var)
- (define fieldname "action")
- (if (or (opensmtpd-relay? var)
- (opensmtpd-local-delivery? var)
- (eq? (quote reject) var))
- var
- (begin
- (report-error (G_ "(~a \"~a\") is invalid.~%")
- fieldname var)
- (display-hint
- (G_ "Try an (opensmtpd-relay) record,
- (opensmtpd-local-delivery) record, or (quote reject)."))
- (throw 'bad! var))))))
- (options opensmtpd-match-options
- (default #f)
- (sanitize (lambda (var)
- (sanitize-options-for-opensmtpd-match var)))))
- (define-record-type* <opensmtpd-smtp>
- opensmtpd-smtp make-opensmtpd-smtp
- opensmtpd-smtp?
- (ciphers opensmtpd-smtp-ciphers
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-smtp" "ciphers"
- (list false? string?)))))
- (limit-max-mails opensmtpd-smtp-limit-max-mails
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-smtp"
- "limit-max-mails"
- (list false? integer?)))))
- (limit-max-rcpt opensmtpd-smtp-limit-max-rcpt
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-smtp"
- "limit-max-rcpt"
- (list false? integer?)))))
- ;; TODO the user could enter in "zebra" which would break the config.
- ;; I should sanitize the string to make sure it looks like "50M".
- (max-message-size opensmtpd-smtp-max-message-size
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-smtp"
- "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-sub-addr-delim
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-smtp"
- "sub-addr-delim"
- (list false? integer? string?))))))
- (define-record-type* <opensmtpd-srs>
- opensmtpd-srs make-opensmtpd-srs
- opensmtpd-srs?
- (key opensmtpd-srs-key
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-srs" "key"
- (list false? boolean? my-file-exists?)))))
- (backup-key opensmtpd-srs-backup-key
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-srs" "backup-key"
- (list false? integer?
- my-file-exists?)))))
- ;; TODO the user could set the string to be "zebra", which would break
- ;; the config.
- (ttl-delay opensmtpd-srs-ttl-delay
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-srs" "ttl-delay"
- (list false? string?))))))
- (define-record-type* <opensmtpd-queue>
- opensmtpd-queue make-opensmtpd-queue
- opensmtpd-queue?
- (compression opensmtpd-queue-compression
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-queue" "compression"
- (list boolean?)))))
- (encryption opensmtpd-queue-encryption
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-queue" "encryption"
- (list boolean? string?
- my-file-exists?)))))
- ;; TODO the user could set the string to be "zebra", which would break
- ;; the config.
- (ttl-delay opensmtpd-queue-ttl-delay
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-queue" "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
- (default #f))
- ;; FIXME/TODO should I include a admd authservid entry?
- (bounce opensmtpd-configuration-bounce
- (default #f)
- (sanitize
- (lambda (var)
- (cond ((false? var)
- var)
- ((and (list? var)
- (>= 4 (length var))
- (<= 1 (length var))
- (list-of-strings? var)
- (every (lambda (str)
- (and (<= 2 (string-length str))
- ;; last character of str is 's' or 'm'
- ;; or 'h' or 'd'.
- (member (string-take-right str 1)
- (list "s" "m" "h" "d"))
- ;; first part of str is an integer.
- (integer?
- (string->number
- (string-take str
- (- (string-length str)
- 1 ))))))
- var))
- var)
- (else
- ;; FIXME TODO I am getting a warning that says
- ;; possibly wrong number of arguments to `G_'
- ;; is one of the below lines to blame?
- (if (string? var)
- (report-error (G_ "(bounce \"~a\") is invalid.\n") var)
- (report-error (G_ "(bounce ~a) is invalid.\n") var))
- (display-hint (G_ "Try (bounce (list \"30m\" \"2h\"))\n"))
- (throw 'bad! var))))))
- (cas opensmtpd-configuration-cas
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-configuration" "cas"
- (list false? list-of-opensmtpd-ca?)))))
- ;; list of many records of type opensmtpd-interface
- (interfaces opensmtpd-configuration-interfaces
- (default (list (opensmtpd-interface)))
- (sanitize
- (lambda (var)
- ;; This makes sure that no opensmtpd-interface is like this:
- ;; (opensmtpd-interface (senders #f) (masquerade #t)), which
- ;; is a syntax error.
- (define (correct-senders? interface)
- (not
- (and (not (opensmtpd-interface-senders interface))
- (opensmtpd-interface-masquerade interface))))
- (define fieldname "interface")
- ;; TODO rework this sanitize bit, so that if someone writes:
- ;; (opensmtpd-interface (senders #f) (masquerade #t)), they
- ;; get a proper error.
- ;; (report-error
- ;; (G_ "((senders #f) & (masquerade #t)) is invalid.\n"))
- (if (and (list-of-interface? var)
- (every correct-senders? var)
- (not (contains-duplicate? var)))
- var
- (begin
- (display "<opensmtpd-configuration> fieldname ")
- (display "'interface' may be #f or a list of records")
- (display "\n of unique <opensmtpd-interface>.\n")
- (throw 'bad! var))))))
- (socket opensmtpd-configuration-socket
- (default #f)
- (sanitize
- (lambda (var)
- (define fieldname "socket")
- (if (or (opensmtpd-socket? var)
- (false? var))
- var
- (begin
- (report-error (G_ "(~a \"~a\") is invalid.~%")
- fieldname var)
- (display-hint
- (G_
- (string-append "Try an ("
- fieldname
- " (opensmtpd-socket ...)) .\n")))
- (throw 'bad! var))))))
- ;; list of strings of absolute path names
- (includes opensmtpd-configuration-includes
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-configuration" "includes"
- (list false? list-of-strings? gexp?)))))
- (matches opensmtpd-configuration-matches
- (default (list (opensmtpd-match
- (action (opensmtpd-local-delivery
- (name "local")
- (method "mbox")))
- (options (list
- (opensmtpd-option
- (option "for local")))))
- (opensmtpd-match
- (action (opensmtpd-relay
- (name "outbound")))
- (options (list
- (opensmtpd-option
- (option "from local"))
- (opensmtpd-option
- (option "for any")))))))
- ;; TODO perhaps I should sanitize this function like I sanitized
- ;; the 'filters'. For example, you could have two different.
- ;; actions, one for local delivery and one for remote,
- ;; with the same name.
- ;; It might be a bit complicated to do this.
- ;; I might just let smtpd figure out if the user made a silly
- ;; mistake by having two different actions with the same name.
- (sanitize (lambda (var)
- var
- (my/sanitize var "opensmtpd-configuration" "matches"
- (list list-of-opensmtpd-match?)))))
- ;; list of many records of type mda-wrapper
- ;; TODO/FIXME support using gexps here
- ;; eg (list "name" gexp)
- ;; TODO what are mda-wrappers for? How do I use this fieldname?
- ;; (mda-wrappers opensmtpd-configuration-mda-wrappers
- ;; (default #f)
- ;; (sanitize (lambda (var)
- ;; (my/sanitize var
- ;; "opensmtpd-configuration"
- ;; "mda-wrappers"
- ;; (list false? string?)))))
- (mta-max-deferred opensmtpd-configuration-mta-max-deferred
- (default 100)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-configuration"
- "mta-max-deferred"
- (list number?)))))
- (queue opensmtpd-configuration-queue
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-configuration" "queue"
- (list false? opensmtpd-queue?)))))
- (smtp opensmtpd-configuration-smtp
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-configuration" "smtp"
- (list false? opensmtpd-smtp?)))))
- (srs opensmtpd-configuration-srs
- (default #f)
- (sanitize (lambda (var)
- (my/sanitize var "opensmtpd-configuration" "srs"
- (list false? opensmtpd-srs?)))))
- (setgid-commands? opensmtpd-setgid-commands? (default #t)))
- ;; this help procedure is used 3 or 4 times by
- ;; sanitize-options-for-opensmtpd-match
- (define* (throw-error-duplicate-option option error-arg
- #:key (record-name "match"))
- (throw-error error-arg
- (list
- (string-append "(opensmtpd-" record-name
- ") (options ...)) can only have one \n"
- "(opensmtpd-option (option \"" option
- "\")) record, but more are present. \n"))
- #:duplicate-option #t))
- ;; this procedure sanitizes the fieldname opensmtpd-match-options
- (define* (sanitize-options-for-opensmtpd-match %options)
- (define option-list (list "for any" "for local" "for domain"
- "for rcpt-to" "from any" "from auth"
- "from local" "from mail-from" "from rdns"
- "from socket" "from src" "auth" "helo"
- "mail-from" "rcpt-to" "tag" "tls"))
- (when (not (list-of-opensmtpd-option? %options))
- (report-error (G_ ""))
- (display
- (string-append "(opensmtpd-match (options ...)) is a list of unique"
- " (opensmtpd-option ...) records.\nIt's value is: "))
- (display %options)
- (display "\n")
- (throw 'bad! %options))
- (let loop ((%traversing-options %options)
- ;; sanitized-options is an alist that may end of looking
- ;; like:
- ;; (("for" (opensmtpd-option (option "for any")))
- ;; ("from" (opensmtpd-option (option "from any")))
- ;; ("tag (opensmtpd-option (option "tag") (data "tag")))
- (%sanitized-options '())
- (option-record (if (null? %options)
- '()
- (car %options)))
- (option-string (if (null? %options)
- '()
- (opensmtpd-option-option
- (car %options)))))
- (cond
- ((null? %traversing-options)
- %options)
- ;; error if option-string is invalid option
- ((not (member option-string option-list))
- (report-error (G_ "(opensmtpd-match \"~a\")) is invalid.\n")
- option-string)
- (display-hint (G_ ""))
- (display (hint-string option-string option-list #:fieldname "option"))
- (throw 'bad! option-string))
- ;; error, if duplicate option
- ((assoc-ref %sanitized-options option-string)
- (report-error (G_ ""))
- (display (string-append "(opensmtpd-match (options ...)) can "
- "only have one (opensmtpd-option (option "
- "\"" option-string "\")), but more "
- " \n are present.\n"))
- (display-hint
- (format #f (G_ "Try removing one (opensmtpd-option (option \"~a\")).~%")
- option-string))
- (throw 'bad! option-record))
- ;; error, if duplicate from or duplicate for option
- ((or
- (if (and (string=? "for" (substring option-string 0 3))
- (assoc-ref %sanitized-options "for"))
- #t
- #f)
- (if (and (>= (length (string->list option-string)) 4)
- (string=? "from" (substring option-string 0 4))
- (assoc-ref %sanitized-options "from"))
- #t
- #f))
- (throw-error %options
- (list "(opensmtpd-match (options ...)) can only have one"
- " (option \"for ...\") and one (option \"from ...\")"
- "\nBut (option \"" option-string "\") and (option \""
- (opensmtpd-option-option
- (if (assoc-ref %sanitized-options "for")
- (assoc-ref %sanitized-options "for")
- (assoc-ref %sanitized-options "from")))
- "\") are present.\n")
- #:hint-strings
- (list "Try removing one "
- (if (string=? "for" (substring option-string 0 3))
- "(opensmtpd-option (option \"for ...\"))"
- "(opensmtpd-option (option \"from ...\"))")
- " record.\n")))
- ;; these 3 options must have fieldname data defined.
- ((and (member option-string
- (list "helo" "mail-from" "rcpt-to"))
- (not (opensmtpd-option-data option-record)))
- (report-error (G_ ""))
- (display (string-append "(option \"" option-string
- "\") must have (data ...) of type string or an "
- "(opensmtpd-table ...) record.\n"))
- (throw 'bad! option-string))
- ;; fieldname data must be a string.
- ((and (string=? "tag" option-string)
- (not (string? (opensmtpd-option-data option-record))))
- (throw-error option-record
- (list "(opensmtpd-match ... (option \"tag\"))"
- " must have a 'data' of type string.\n")))
- ((or (string=? "tls" option-string)
- (string=? "for" (substring option-string 0 3))
- (string=? "from" (substring option-string 0 4)))
- ;; let's test the "for" and "from" options now.
- (cond
- ;; the options in this list cannot define 'data' or 'regex'
- ;; fieldnames.
- ((and (member option-string (list "for local" "for any"
- "from any" "from local"
- "from socket" "tls"))
- (or (opensmtpd-option-data option-record)
- (opensmtpd-option-regex option-record)))
- (report-error (G_ ""))
- (display (string-append "When (openmstpd-option (option \""
- option-string "\") ...), "
- "then (data ...) and (regex ...) "
- "must be #f. \n"))
- (throw 'bad! option-record))
- ;; the options in this list must have a data field of type
- ;; string or tables-data-are-a-list-of-strings?
- ((and (member option-string
- (list "for domain" "for rcpt-to"
- "from mail-from" "from src"))
- (or (false? (opensmtpd-option-data option-record))
- (tables-data-are-assoc-list?
- (opensmtpd-option-data option-record))))
- (throw-error option-record
- (list "When (openmstpd-option (option \""
- option-string "\") ...) \n"
- "then (data ...) must be a string or an \n"
- "(opensmtpd-table ....) record whose "
- "'data' is a list of strings.\n")))
- (else
- (loop (cdr %traversing-options)
- (alist-cons
- (cond ((string=? "for" (substring option-string 0 3))
- "for")
- ((string=? "tls" option-string)
- "tls")
- (else "from"))
- option-record
- %sanitized-options)
- ;;option-record
- (if (null? (cdr %traversing-options))
- '()
- (car (cdr %traversing-options)))
- ;; option-string
- (if (null? (cdr %traversing-options))
- '()
- (opensmtpd-option-option
- (car (cdr %traversing-options))))))))
- ;; TODO if auth's 'data' is an assoc-list table, then
- ;; it IS invalid!
- ;; option-string = 'auth' cannot be made invalidly,
- ;; do not test for it.
- (else
- (loop (cdr %traversing-options)
- (alist-cons option-string option-record
- %sanitized-options)
- ;;option-record
- (if (null? (cdr %traversing-options))
- '()
- (car (cdr %traversing-options)))
- ;; option-string
- (if (null? (cdr %traversing-options))
- '()
- (opensmtpd-option-option
- (car (cdr %traversing-options)))))))))
- (define (filter-phase-has-message-and-value? record)
- (and (opensmtpd-filter-phase-message record)
- (opensmtpd-filter-phase-value record)))
- ;; return #t if phase needs a message. Or if the message did not start
- ;; with a 4xx or 5xx status code. otherwise #f
- (define (filter-phase-decision-lacks-proper-message? record)
- (define decision (opensmtpd-filter-phase-decision record))
- (if (member decision (list "disconnect" "reject"))
- ;; this message needs to be RFC compliant, meaning
- ;; that it need to start with 4xx or 5xx status code
- (cond ((eq? #f (opensmtpd-filter-phase-message record))
- #t)
- ((string? (opensmtpd-filter-phase-message record))
- (let ((number (string->number
- (substring
- (opensmtpd-filter-phase-message record) 0 3))))
- (if (and (number? number)
- (and (< number 600) (> number 399)))
- #f
- #t))))
- #f))
- ;; 'decision' "rewrite" requires 'value' to be a number.
- (define (filter-phase-lacks-proper-value? record)
- (define decision (opensmtpd-filter-phase-decision record))
- (if (string=? "rewrite" decision)
- (if (and (number? (opensmtpd-filter-phase-value record))
- (eq? #f (opensmtpd-filter-phase-message record)))
- #f
- #t)
- #f))
- ;; 'decision' "junk" or "bypass" cannot have a message or a value.
- (define (filter-phase-has-incorrect-junk-or-bypass? record)
- (and
- (member
- (opensmtpd-filter-phase-decision record)
- (list "junk" "bypass"))
- (or
- (opensmtpd-filter-phase-value record)
- (opensmtpd-filter-phase-message record))))
- (define (filter-phase-junks-after-commit? record)
- (and (string=? "junk" (opensmtpd-filter-phase-decision record))
- (string=? "commit" (opensmtpd-filter-phase-phase record))))
- ;; returns #t if list is a unique list of <opensmtpd-filter> or
- ;; <opensmtpd-filter-phase> returns # otherwise
- ;; only opensmtpd-filter-chain? uses this function, and opensmtpd-filter-chain
- ;; is NEVER actually used.
- ;; I could possibly remove it.
- (define (list-of-unique-filter-or-filter-phase? %filters)
- (and (list? %filters)
- (not (null? %filters))
- ;; this list is made up of only <opensmtpd-filter-phase>
- ;; or <opensmtpd-filter>
- (every (lambda (filter)
- (or (opensmtpd-filter? filter)
- (opensmtpd-filter-phase? filter)))
- %filters)
- ;; each filter-name is unique.
- (not (duplicate-filter-name %filters))))
- (define (filters->list-of-filter-names %filters)
- (map (lambda (filter)
- (cond ((opensmtpd-filter-phase? filter)
- (opensmtpd-filter-phase-name filter))
- (else (opensmtpd-filter-name filter))))
- %filters))
- (define (duplicate-string-in-list strings)
- (define first-string (car strings))
- (cond ((null? (cdr strings))
- #f)
- ((any (lambda (element)
- (if (string=? element first-string)
- element
- #f))
- (cdr strings))
- first-string)
- (else (duplicate-string-in-list (cdr strings)))))
- (define (duplicate-filter-name %filters)
- (define filter-names (filters->list-of-filter-names %filters))
- (duplicate-string-in-list filter-names))
- ;; the sanitize procedures used for sanitizing each <opensmtpd-interface> and
- ;; <opensmtpd-socket> fieldname 'filters'.
- ;; It primarily sanitizes <filter-phases>. The only sanitization it does
- ;; for <filter>s, is no make sure there are no duplicate filter names.
- (define* (sanitize-socket-and-interfaces-filters
- %filters
- #:key (socket-or-interface "interface"))
- ;; if there are two filters with the same name, store that name here.
- (define the-duplicate-filter-name
- (if (not %filters)
- #f
- (duplicate-filter-name %filters)))
- (define %filter-phases
- (if (not %filters)
- '()
- (remove opensmtpd-filter? %filters)))
- ;; the order of the first two tests in this cond is important.
- ;; (false?) has to be 1st and (duplicate-filter-filter-name) has to be
- ;; second. You may optionally re-order the other alternates in the cond.
- (cond ((false? %filters)
- #f)
- (the-duplicate-filter-name
- (report-error (G_ ""))
- (display (string-append
- "(opensmtpd-" socket-or-interface
- " (filters ...)) has a duplicate filter name: \""
- the-duplicate-filter-name "\".\n"))
- (throw 'bad! %filters))
- (else
- (let loop ((%traversing-list %filter-phases)
- (fieldname (if (null? %filter-phases)
- '()
- (opensmtpd-filter-phase-decision
- (car %filter-phases)))))
- (cond
- ((null? %traversing-list)
- %filters)
- ((opensmtpd-filter? (car %traversing-list))
- (loop (cdr %traversing-list)
- (if (null? (cdr %traversing-list))
- '()
- (opensmtpd-filter-phase-decision
- (car (cdr %traversing-list))))))
- ((filter-phase-has-message-and-value?
- (car %traversing-list))
- (report-error (G_ ""))
- (display
- (string-append "(opensmtpd-filter-phase ...) cannot define "
- "fieldnames 'value' \n and 'message'.\n")))
- ((filter-phase-decision-lacks-proper-message?
- (car %traversing-list))
- (cond
- ((string? fieldname)
- (report-error
- (G_ "(decision \"~a\") with (message ...) is invalid.~%")
- fieldname))
- ((or (integer? fieldname) (boolean? fieldname))
- (report-error
- (G_ "(decision ~a) with (message ...) is invalid.~%")
- fieldname))
- (else
- (report-error
- (G_ "(~a ...\") with (message ...) is invalid.~%... is ~a")
- fieldname)))
- (display-hint
- (G_ (string-append "Try (opensmtpd-filter-phase "
- "(message \"406 Not acceptable.\") "
- "(decision \"" fieldname "\")).\n")))
- (throw 'bad! (car %traversing-list)))
- ((filter-phase-lacks-proper-value? (car %traversing-list))
- (begin
- (report-error (G_ ""))
- (display
- (string-append
- "(opensmtpd-filter-phase (decision \"rewrite\")"
- "\n\t\t(value ...)) must be a number.\n"))
- (display-hint (G_ "Try (value 5)."))
- (throw 'bad! (car %traversing-list))))
- ((filter-phase-has-incorrect-junk-or-bypass?
- (car %traversing-list))
- (begin
- (report-error (G_ ""))
- (display
- (string-append "(opensmtpd-filter-phase (decision \""
- (opensmtpd-filter-phase-decision
- (car %traversing-list))
- "\") cannot define (message ...) or "
- "(value ...).\n"))
- (throw 'bad! (car %traversing-list))))
- ((filter-phase-junks-after-commit? (car %traversing-list))
- (begin
- (report-error (G_ ""))
- (display
- (string-append
- "(opensmtpd-filter-phase (decision \"junk\")\n\t\t "
- "(phase \"commit\")) is invalid.\n"))
- (display-hint
- (G_ (string-append "You cannot junk an email during phase "
- "\"commit\". Try (phase \"data\").\n")))
- (throw 'bad! (car %traversing-list))))
- (else (loop (cdr %traversing-list)
- (if (null? (cdr %traversing-list))
- '()
- (opensmtpd-filter-phase-decision
- (car (cdr %traversing-list)))))))))))
- (define* (sanitize-options-for-filter-phase %options)
- (define option-list
- (list "fcrdns" "rdns" "src" "helo" "auth" "mail-from" "rcpt-to"))
- (let loop ((%traversing-options %options)
- ;; sanitized-options is an alist that may end of looking like:
- ;; (("fcrdns" (opensmtpd-option (option "fcrdns")))
- ;; ("auth" (opensmtpd-option (option "auth"))))
- (%sanitized-options '())
- (option-record (if (null? %options)
- '()
- (car %options)))
- (option-string (if (null? %options)
- '()
- (opensmtpd-option-option (car %options)))))
- (cond
- ((null? %traversing-options)
- %options)
- ;; error if option-string is invalid option
- ((not (member option-string option-list))
- (report-error
- (G_ "(opensmtpd-filter-phase (option \"~a\")) is invalid.\n")
- option-string)
- (display-hint (G_ ""))
- (display (hint-string option-string option-list
- #:fieldname "option"))
- (throw 'bad! option-string))
- ;; if we see two "rdns" (for example), throw a
- ;; "duplicate option" error.
- ((assoc-ref %sanitized-options option-string)
- (report-error (G_ ""))
- (display (string-append "(opensmtpd-filter-phase (options ...)) can "
- "only have one\n (opensmtpd-option (option \""
- option-string "\")), but more are present.\n"))
- (display-hint
- (format #f (G_ "Try removing one (option \"~a\").~%") option-string))
- (throw 'bad! option-record))
- ;; the next 4 options must have fieldname 'data' defined.
- ((and (member option-string
- (list "src" "helo" "mail-from" "rcpt-to"))
- (not (opensmtpd-table? (opensmtpd-option-data option-record))))
- (report-error (G_ ""))
- (display (string-append "(opensmtpd-filter-phase ... " "(option \""
- option-string "\")) must define (data ...).\n"))
- (display-hint (G_ "Try defining (data (opensmtpd-table ...).\n"))
- (throw 'bad! option-record))
- ;;fcrdns cannot have fieldname data defined
- ((and (string=? "fcrdns" option-string)
- (opensmtpd-option-data option-record))
- (report-error (G_ ""))
- (display (string-append "(opensmtpd-option \"" option-string "\") "
- "cannot define (data ...).\n"))
- (display-hint (G_ ""))
- (display "Try removing (data ...).\n")
- (throw 'bad! option-record))
- ;; rdns and auth cannot be made invalidly.
- ;; skip testing them.
- (else (loop (cdr %traversing-options)
- (alist-cons option-string option-record
- %sanitized-options)
- ;; option-record
- (if (null? (cdr %traversing-options))
- '()
- (car (cdr %traversing-options)))
- ;; option-string
- (if (null? (cdr %traversing-options))
- '()
- (opensmtpd-option-option
- (car (cdr %traversing-options)))))))))
- (define* (throw-error var %strings
- #:key
- (record-name #f)
- (duplicate-option #f)
- (fieldname #f)
- (hint-strings #f))
- (cond ((and record-name fieldname)
- (cond ((or (string? var))
- (report-error (G_ "(~a \"~a\") is invalid.~%") fieldname var))
- ((boolean? var)
- (report-error (G_ "(~a ~a) is invalid.~%") fieldname var))
- ((number? var)
- (report-error (G_ "(~a ~a) is invalid.~%") fieldname
- (number->string var)))
- (else
- (report-error (G_ "(~a ...) is invalid.~%Its value is: ~a~%")
- fieldname var)))
- (display-hint (G_ (string-append "(opensmtpd-" record-name
- " (fieldname " fieldname "...)) "
- (apply string-append %strings))))
- (throw 'bad! var))
- ((list? hint-strings)
- (report-error (G_ ""))
- (display (apply string-append %strings))
- (display-hint (G_ (apply string-append hint-strings)))
- (throw 'bad! var))
- ;; display the output for throw-error-duplicate-option
- (duplicate-option
- (report-error (G_ ""))
- (display (apply string-append %strings))
- (display-hint
- (format #f
- (G_ "Try removing one (opensmtpd-option \"~a\") option.\n")
- var))
- (throw 'bad! var))
- (else
- (report-error (G_ ""))
- (display (apply string-append %strings))
- (throw 'bad! var))))
- ;; if strings is (list "auth" "for any" "from local")
- ;; Then this will return "Try \"auth\", \"for any\", or \"from local\".
- (define (try-string strings)
- (string-append "Try "
- (let loop ((strings strings))
- (cond ((= 1 (length strings))
- (string-append
- "or \"" (car strings) "\".\n"))
- (else
- (string-append
- "\"" (car strings) "\", "
- (loop (cdr strings))))))))
- ;; suppose string is "for anys"
- ;; and strings is (list "for any" "for local" "for domain")
- ;; then hint-string will return "Did you mean "for any"?"
- (define* (hint-string string strings
- #:key (fieldname #f))
- (define str (string-closest string strings))
- (if (not str)
- (try-string strings)
- (if fieldname
- (string-append "Did you mean (" fieldname " \""
- str "\") ?\n")
- (string-append "Did you mean \"" str "\" ?\n"))))
- ;; this is used for sanitizing <opensmtpd-filter-phase> fieldname 'options'
- (define (contains-duplicate? list)
- (if (null? list)
- #f
- (or
- ;; check if (car list) is in (cdr list)
- (any (lambda (var)
- (equal? var (car list)))
- (cdr list))
- ;; check if (cdr list) contains duplicate
- (contains-duplicate? (cdr list)))))
- (define* (variable->string var #:key (append "") (postpend " "))
- (let ((var (if (number? var)
- (number->string var)
- var)))
- (if var
- (string-append append var postpend)
- "")))
- ;;; Various functions to check that lists are of the appropriate type.
- ;; 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?))
- (define (list-of-interface? list)
- (list-of-type? list opensmtpd-interface?))
- (define (list-of-opensmtpd-option? list)
- (list-of-type?
- list opensmtpd-option?))
- (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-match? list)
- (list-of-type? list opensmtpd-match?))
- (define* (list-of-strings->string list
- #:key
- (string-delimiter ", ")
- (postpend "")
- (append "")
- (drop-right-number 2))
- (string-drop-right
- (string-append (let loop ((list list))
- (if (null? list)
- ""
- (string-append append (car list) postpend
- string-delimiter
- (loop (cdr list)))))
- append)
- drop-right-number))
- ;; TODO I should probably change this to alist, because that's what this is.
- (define (assoc-list? assoc-list)
- (list-of-type? assoc-list
- (lambda (pair)
- (and (pair? pair)
- (string? (car pair))
- (string? (cdr pair))
- (<= 1 (string-length (car pair)))
- (<= 1 (string-length (cdr pair)))))))
- (define (nested-list? list)
- (every (lambda (element)
- (and
- (list-of-strings? element)
- (< 1 (length element))))
- list))
- ;; this procedure takes in one argument.
- ;; if that argument is an <opensmtpd-table> whose fieldname 'values' is
- ;; an assoc-list, then it returns #t, #f if otherwise.
- (define (tables-data-are-assoc-list? table)
- (if (not (opensmtpd-table? table))
- #f
- (assoc-list? (opensmtpd-table-data table))))
- ;; this procedure takes in one argument
- ;; if that argument is an <opensmtpd-table> whose fieldname 'values' is a
- ;; list of strings, then it returns #t, #f if otherwise.
- (define (tables-data-are-a-list-of-strings? table)
- (if (not (opensmtpd-table? table))
- #f
- (and (list-of-strings? (opensmtpd-table-data table)))))
- ;; This procedures takes in an <opensmtpd-table>
- ;; if that table a list of lists of strings eg:
- ;; (list (list "cat") (list "dog"))
- ;; then this returns #t, otherwise false.
- (define (tables-data-are-a-nested-list-of-strings? table)
- (cond ((false? (opensmtpd-table-data table))
- #f)
- ((not (list? (opensmtpd-table-data table)))
- #f)
- (else
- (nested-list? (opensmtpd-table-data table)))))
- ;;; The following functions convert various records into strings.
- ;; these next few functions help me to turn <table>s
- ;; into strings suitable to fit into "opensmtpd.conf".
- (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))
- ;; can be of type: (quote list-of-strings) or (quote assoc-list)
- ;; this will output a string that looks like:
- ;; table <"mytable"> { "ludo"="ludo@gnu.org" }
- (define (opensmtpd-table->string table)
- (string-append "table \"" (opensmtpd-table-name table) "\" "
- (cond ((tables-data-are-a-list-of-strings? table)
- (string-append "{ "
- (list-of-strings->string
- (opensmtpd-table-data table)
- #:append "\""
- #:drop-right-number 3
- #:postpend "\"") " }"))
- ((tables-data-are-assoc-list? table)
- (string-append "{ "
- (assoc-list->string
- (opensmtpd-table-data table)) " }"))
- (else (throw 'youMessedUp table)))
- " \n"))
- ;; will output something like:
- ;; <"mytable">
- (define (opensmtpd-table-name->string table)
- (string-append "<\"" (opensmtpd-table-name table) "\">"))
- (define (opensmtpd-interface->string record)
- (string-append
- "listen on "
- (opensmtpd-interface-interface record) " "
- (let* ((hostname (opensmtpd-interface-hostname record))
- (hostnames (if (opensmtpd-interface-hostnames record)
- (opensmtpd-table-name
- (opensmtpd-interface-hostnames record))
- #f))
- (filters (opensmtpd-interface-filters record))
- (filter-name (if filters
- (if (< 1 (length filters))
- (generate-filter-chain-name filters)
- (if (opensmtpd-filter? (car filters))
- (opensmtpd-filter-name (car filters))
- (opensmtpd-filter-phase-name
- (car filters))))
- #f))
- (mask-src (opensmtpd-interface-mask-src record))
- (tag (opensmtpd-interface-tag record))
- (senders (opensmtpd-interface-senders record))
- (masquerade (opensmtpd-interface-masquerade record))
- (secure-connection (opensmtpd-interface-secure-connection record))
- (port (opensmtpd-interface-port record))
- (pki (opensmtpd-interface-pki record))
- (auth (opensmtpd-interface-auth record))
- (auth-optional (opensmtpd-interface-auth-optional record)))
- (string-append
- (if mask-src
- (string-append "mask-src ")
- "")
- (variable->string hostname #:append "hostname ")
- (variable->string hostnames #:append "hostnames <" #:postpend "> ")
- (variable->string filter-name #:append "filter \"" #:postpend "\" ")
- (variable->string tag #:append "tag \"" #:postpend "\" ")
- (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 senders
- (string-append "senders <\"" (opensmtpd-table-name senders) "\"> "
- (if masquerade
- "masquerade "
- ""))
- "")
- (variable->string port #:append "port " #:postpend " ")
- (if pki
- (variable->string (opensmtpd-pki-domain pki) #:append "pki ")
- "")
- (if auth
- (string-append "auth "
- (if (opensmtpd-table? auth)
- (string-append
- (opensmtpd-table-name->string auth))
- ""))
- "")
- (if auth-optional
- (string-append "auth-optional "
- (if (opensmtpd-table? auth-optional)
- (string-append
- "<\""
- (opensmtpd-table-name->string auth-optional)
- "\">")
- ""))
- "")
- "\n"))))
- (define (opensmtpd-socket->string record)
- (string-append
- "listen on socket "
- (let* ((filters (opensmtpd-socket-filters record))
- (filter-name (if filters
- (if (< 1 (length filters))
- (generate-filter-chain-name filters)
- (if (opensmtpd-filter? (car filters))
- (opensmtpd-filter-name (car filters))
- (opensmtpd-filter-phase-name
- (car filters))))
- #f))
- (mask-src (opensmtpd-socket-mask-src record))
- (tag (opensmtpd-socket-tag record)))
- (string-append
- (if mask-src
- (string-append "mask-src ")
- "")
- (variable->string filter-name #:append "filter \"" #:postpend "\" ")
- (variable->string tag #:append "tag \"" #:postpend "\" ")
- "\n"))))
- (define (opensmtpd-relay->string record)
- (let ((backup (opensmtpd-relay-backup record))
- (backup-mx (opensmtpd-relay-backup-mx record))
- (helo (opensmtpd-relay-helo record))
- ;; helo-src can either be a string IP address or an <opensmtpd-table>
- (helo-src (if (opensmtpd-relay-helo-src record)
- (if (string? (opensmtpd-relay-helo-src record))
- (opensmtpd-relay-helo-src record)
- (string-append "<\""
- (opensmtpd-table-name
- (opensmtpd-relay-src record))
- "\">"))
- #f))
- (domain (if (opensmtpd-relay-domain record)
- (opensmtpd-table-name
- (opensmtpd-relay-domain record))
- #f))
- (host (opensmtpd-relay-host record))
- (name (opensmtpd-relay-name record))
- (pki (if (opensmtpd-relay-pki record)
- (opensmtpd-pki-domain (opensmtpd-relay-pki record))
- #f))
- (srs (opensmtpd-relay-srs record))
- (tls (opensmtpd-relay-tls record))
- (auth (if (opensmtpd-relay-auth record)
- (opensmtpd-table-name
- (opensmtpd-relay-auth record))
- #f))
- (mail-from (opensmtpd-relay-mail-from record))
- ;; src can either be a string IP address or an <opensmtpd-table>
- (src (if (opensmtpd-relay-src record)
- (if (string? (opensmtpd-relay-src record))
- (opensmtpd-relay-src record)
- (string-append "<\""
- (opensmtpd-table-name
- (opensmtpd-relay-src record))
- "\">"))
- #f)))
- (string-append
- "\""
- name
- "\" " "relay "
- ;;FIXME should I always quote the host fieldname?
- ;; do I need to quote localhost via "localhost" ?
- (variable->string host #:append "host \"" #:postpend "\" ")
- (variable->string backup)
- (variable->string backup-mx #:append "backup mx ")
- (variable->string helo #:append "helo ")
- (variable->string helo-src #:append "helo-src ")
- (variable->string domain #:append "domain <\"" #:postpend "\"> ")
- (variable->string host #:append "host ")
- (variable->string pki #:append "pki ")
- (variable->string srs)
- (variable->string tls #:append "tls ")
- (variable->string auth #:append "auth <\"" #:postpend "\"> ")
- (variable->string mail-from #:append "mail-from ")
- (variable->string src #:append "src ")
- "\n")))
- (define (opensmtpd-lmtp->string record)
- (string-append "lmtp "
- (opensmtpd-lmtp-destination record)
- (if (opensmtpd-lmtp-rcpt-to record)
- (begin
- " " (opensmtpd-lmtp-rcpt-to record))
- "")))
- (define (opensmtpd-mda->string record)
- (string-append "mda "
- (opensmtpd-mda-command record) " "))
- (define (opensmtpd-maildir->string record)
- (string-append "maildir "
- "\""
- (if (opensmtpd-maildir-pathname record)
- (opensmtpd-maildir-pathname record)
- "~/Maildir")
- "\""
- (if (opensmtpd-maildir-junk record)
- " junk "
- " ")))
- (define (opensmtpd-local-delivery->string record)
- (let ((name (opensmtpd-local-delivery-name record))
- (method (opensmtpd-local-delivery-method record))
- (alias (if (opensmtpd-local-delivery-alias record)
- (opensmtpd-table-name
- (opensmtpd-local-delivery-alias record))
- #f))
- (ttl (opensmtpd-local-delivery-ttl record))
- (user (opensmtpd-local-delivery-user record))
- (userbase (if (opensmtpd-local-delivery-userbase record)
- (opensmtpd-table-name
- (opensmtpd-local-delivery-userbase record))
- #f))
- (virtual (if (opensmtpd-local-delivery-virtual record)
- (opensmtpd-table-name
- (opensmtpd-local-delivery-virtual record))
- #f))
- (wrapper (opensmtpd-local-delivery-wrapper record)))
- (string-append
- "\"" name "\" "
- (cond ((string? method)
- (string-append method " "))
- ((opensmtpd-mda? method)
- (opensmtpd-mda->string method))
- ((opensmtpd-lmtp? method)
- (opensmtpd-lmtp->string method))
- ((opensmtpd-maildir? method)
- (opensmtpd-maildir->string method)))
- ;; FIXME/TODO support specifying alias file:/path/to/alias-file ?
- ;; I do not think that is something that I can do...
- (variable->string alias #:append "alias <\"" #:postpend "\"> ")
- (variable->string ttl #:append "ttl ")
- (variable->string user #:append "user ")
- (variable->string userbase #:append "userbase <\"" #:postpend "\"> ")
- (variable->string virtual #:append "virtual <\"" #:postpend "\"> ")
- (variable->string wrapper #:append "wrapper "))))
- ;; this function turns both opensmtpd-local-delivery and
- ;; opensmtpd-relay into strings.
- (define (opensmtpd-action->string record)
- (string-append "action "
- (cond ((opensmtpd-local-delivery? record)
- (opensmtpd-local-delivery->string record))
- ((opensmtpd-relay? record)
- (opensmtpd-relay->string record)))
- " \n"))
- ;; this turns option records found in <opensmtpd-match> into strings.
- (define* (opensmtpd-option->string record
- #:key
- (space-after-! #f))
- (let ((bool (opensmtpd-option-bool record))
- (option (opensmtpd-option-option record))
- (regex (opensmtpd-option-regex record))
- (data (opensmtpd-option-data record)))
- (string-append
- (if (false? bool)
- (if space-after-!
- "! "
- "!")
- "")
- option " "
- (if regex
- "regex "
- "")
- (if data
- (if (opensmtpd-table? data)
- (string-append
- (opensmtpd-table-name->string data) " ")
- (string-append data " "))
- ""))))
- (define (opensmtpd-match->string record)
- (string-append "match "
- (let* ((action (opensmtpd-match-action record))
- (name (cond ((opensmtpd-relay? action)
- (opensmtpd-relay-name action))
- ((opensmtpd-local-delivery? action)
- (opensmtpd-local-delivery-name action))
- (else 'reject)))
- (options (opensmtpd-match-options record)))
- (string-append
- (if options
- (apply string-append
- (map opensmtpd-option->string options))
- "")
- (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)
- (let ((domain (opensmtpd-pki-domain record))
- (cert (opensmtpd-pki-cert record))
- (key (opensmtpd-pki-key record))
- (dhe (opensmtpd-pki-dhe record)))
- (string-append "pki " domain " " "cert \"" cert "\" \n"
- "pki " domain " " "key \"" key "\" \n"
- (if dhe
- (string-append
- "pki " domain " " "dhe " dhe "\n")
- ""))))
- (define (generate-filter-chain-name list-of-filters)
- (string-drop-right (apply string-append
- (flatten
- (map (lambda (filter)
- (list
- (if (opensmtpd-filter? filter)
- (opensmtpd-filter-name filter)
- (opensmtpd-filter-phase-name filter))
- "-"))
- list-of-filters)))
- 1))
- (define (opensmtpd-filter->list-of-strings-and-gexps record)
- (list "filter "
- "\"" (opensmtpd-filter-name record) "\" "
- (if (opensmtpd-filter-exec record)
- "proc-exec "
- "proc ")
- "\"" (opensmtpd-filter-proc record) "\""
- "\n\n"))
- ;; this procedure takes in a list of <opensmtpd-filter> and
- ;; <opensmtpd-filter-phase>. It returns a string of the form:
- ;; filter "uniqueName" chain chain { "filter-name", "filter-name2" [, ...]}
- (define (opensmtpd-filter-chain->string list-of-filters)
- (string-append "filter \""
- (generate-filter-chain-name list-of-filters)
- "\" "
- "chain {"
- (string-drop-right
- (apply string-append
- (flatten
- (map (lambda (filter)
- (list
- "\""
- (if (opensmtpd-filter? filter)
- (opensmtpd-filter-name filter)
- (opensmtpd-filter-phase-name filter))
- "\", "))
- list-of-filters)))
- 2)
- "}\n\n"))
- (define (opensmtpd-filter-phase->string record)
- (let ((name (opensmtpd-filter-phase-name record))
- (phase (opensmtpd-filter-phase-phase record))
- (decision (opensmtpd-filter-phase-decision record))
- (options (opensmtpd-filter-phase-options record))
- (message (opensmtpd-filter-phase-message record))
- (value (opensmtpd-filter-phase-value record)))
- (string-append "filter "
- "\"" name "\" "
- "phase " phase " "
- "match "
- (apply string-append ; turn the options into a string
- (flatten
- (map (lambda (option)
- (opensmtpd-option->string
- option #:space-after-! #f))
- options)))
- " "
- decision " "
- (if (member decision (list "reject" "disconnect"))
- (string-append "\"" message "\"")
- "")
- (if (string=? "rewrite" decision)
- (string-append "rewrite " (number->string value))
- "")
- "\n\n")))
- ;; in the next procedure, the variable 'filters' is a list of
- ;; <opensmtpd-filter>, <opensmtpd-filter-phase>, and filter chains, which are
- ;; lists that look like:
- ;; (list (opensmtpd-filter ...) (opensmtpd-filter-phase ...)
- ;; (opensmtpd-filter-phase ...) (opensmtpd-filter ...))
- ;; This function converts (get-opensmtpd-filters <opensmtpd-configuration>)
- ;; to a string.
- ;; Consider if a user passed in a valid <opensmtpd-configuration>,
- ;; so that (get-opensmtpd-filters (opensmtpd-configuration)) returns
- ;; (list (opensmtpd-filter
- ;; (name "rspamd")
- ;; (proc "rspamd"))
- ;; ;; this is a listen-on, with a filter-chain.
- ;; (list (opensmtpd-filter-phase
- ;; (name "dkimsign")
- ;; ...)
- ;; (opensmtpd-filter
- ;; (name "rspamd")
- ;; (proc "rspamd"))))
- ;;
- ;; (we will call the above list "total filters"):
- ;; did you notice that filter "rspamd" is listed twice? Once by itself, and
- ;; once again in a filter chain. How do you make sure that it is NOT printed
- ;; twice in smtpd.conf?
- ;; 1st flatten "total filters", then remove its duplicates so that we
- ;; may print the <opensmtpd-filter>s and <opensmtpd-filter-phase>s.
- ;; 2nd now we go through "total filters", and we only print the filter-chains.
- (define (opensmtpd-filters->list-of-strings-and-gexps filters)
- ;; first print the unique <opensmtpd-filter-phase>s and <opensmtpd-filter>s.
- ;; then print the filter-chains.
- ;; to do this: flatten filters, then remove duplicates.
- (flatten
- (list
- ;; TODO for funsies, try to figure out how to list the filter-phases and
- ;; filters in one go. I tried it earlier, and it broke the service.
- ;; Why?
- ;;
- ;; print the filter-phases
- (apply string-append
- (map (lambda (filter)
- (cond ((opensmtpd-filter-phase? filter)
- (opensmtpd-filter-phase->string filter))
- (else "")))
- (delete-duplicates (flatten filters))))
- ;; list the filters that may be gexps
- (map (lambda (filter)
- (cond ((opensmtpd-filter? filter)
- (opensmtpd-filter->list-of-strings-and-gexps filter))
- (else "")))
- (delete-duplicates (flatten filters)))
- ;; now we have to print the filter chains.
- (apply string-append
- (map (lambda (filter)
- (cond ((list? filter)
- (opensmtpd-filter-chain->string filter))
- (else ; you are a <opensmtpd-filter>
- "")))
- filters)))))
- (define (opensmtpd-configuration-includes->string string)
- (string-append
- "include \"" string "\"\n"))
- (define (opensmtpd-configuration-srs->string record)
- (let ((key (opensmtpd-srs-key record))
- (backup-key (opensmtpd-srs-backup-key record))
- (ttl-delay (opensmtpd-srs-ttl-delay record)))
- (string-append
- (variable->string key #:append "srs key " #:postpend "\n")
- (variable->string backup-key #:append "srs key backup " #:postpend "\n")
- (variable->string ttl-delay #:append "srs ttl " #:postpend "\n")
- "\n")))
- ;; TODO make sure all options here work! I just fixed limit-max-rcpt!
- (define (opensmtpd-smtp->string record)
- (let ((ciphers (opensmtpd-smtp-ciphers record))
- (limit-max-mails (opensmtpd-smtp-limit-max-mails record))
- (limit-max-rcpt (opensmtpd-smtp-limit-max-rcpt record))
- (max-message-size (opensmtpd-smtp-max-message-size record))
- (sub-addr-delim (opensmtpd-smtp-sub-addr-delim record)))
- (string-append
- (variable->string ciphers #:append "smtp ciphers " #:postpend "\n")
- (variable->string limit-max-mails
- #:append "smtp limit max-mails " #:postpend "\n")
- (variable->string limit-max-rcpt
- #:append "smtp limit max-rcpt " #:postpend "\n")
- (variable->string max-message-size
- #:append "smtp max-message-size " #:postpend "\n")
- (variable->string sub-addr-delim
- #:append "smtp sub-addr-delim " #:postpend "\n")
- "\n")))
- (define (opensmtpd-configuration-queue->string record)
- (let ((compression (opensmtpd-queue-compression record))
- (encryption (opensmtpd-queue-encryption record))
- (ttl-delay (opensmtpd-queue-ttl-delay record)))
- (string-append
- (if compression
- "queue compression\n"
- "")
- (if encryption
- (string-append
- "queue encryption "
- (if (not (boolean? encryption))
- encryption
- "")
- "\n")
- "")
- (if ttl-delay
- (string-append "queue ttl" ttl-delay "\n")
- ""))))
- ;; build a list of <opensmtpd-action> from
- ;; opensmtpd-configuration-matches, which is a list of <opensmtpd-match>.
- ;; Each <opensmtpd-match> has a fieldname 'action', which accepts
- ;; an <opensmtpd-action>.
- (define (get-opensmtpd-actions record)
- (define opensmtpd-actions
- (let loop ((list (opensmtpd-configuration-matches record)))
- (if (null? list)
- '()
- (cons (opensmtpd-match-action (car list))
- (loop (cdr list))))))
- (delete-duplicates (append opensmtpd-actions)))
- ;; build a list of opensmtpd-pkis from
- ;; opensmtpd-configuration-interfaces and
- ;; get-opensmtpd-actions
- (define (get-opensmtpd-pkis record)
- ;; TODO/FIXME/maybe/wishlist could get-opensmtpd-actions -> NOT have an
- ;; opensmtpd-relay?
- ;; I think so. And if it did NOT have a relay configuration, then
- ;; action-pkis would be '() when it needs to be #f. because if the
- ;; opensmtpd-configuration has NO pkis, then this function will
- ;; return '(), when it should return #f. If it returns '(), then
- ;; opensmtpd-configuration-fieldname->string will
- ;; print the string "\n" instead of ""
- (define action-pkis
- (let loop1 ((list (get-opensmtpd-actions record)))
- (if (null? list)
- '()
- (if (and (opensmtpd-relay? (car list))
- (opensmtpd-relay-pki (car list)))
- (cons (opensmtpd-relay-pki (car list))
- (loop1 (cdr list)))
- (loop1 (cdr list))))))
- ;; FIXME/TODO/maybe/wishlist
- ;; this could be #f aka left blank. aka there are no interface records
- ;; with pkis. aka there are no lines in the configuration like:
- ;; listen on eth0 tls pki smtp.gnucode.me
- ;; in that case the smtpd.conf will have an extra "\n"
- (define listen-on-pkis
- (let loop2 ((list (opensmtpd-configuration-interfaces record)))
- (if (null? list)
- '()
- (if (opensmtpd-interface-pki (car list))
- (cons (opensmtpd-interface-pki (car list))
- (loop2 (cdr list)))
- (loop2 (cdr list))))))
- (delete-duplicates (append action-pkis listen-on-pkis)))
- ;; takes in a <opensmtpd-configuration> and returns a list whose
- ;; elements are <opensmtpd-filter>, <opensmtpd-filter-phase>,
- ;; and a filter-chain.
- ;; It returns a list of <opensmtpd-filter> and/or <opensmtpd-filter-phase>
- ;; here's an example of what this procedure might return:
- ;; (list (opensmtpd-filter...) (opensmtpd-filter-phase ...)
- ;; (openmstpd-filter ...) (opensmtpd-filter-phase ...)
- ;; ;; this next list is a filter-chain.
- ;; (list (opensmtpd-filter-phase ...) (opensmtpd-filter...)))
- ;;
- ;; This procedure handles filter chains a little odd.
- (define (get-opensmtpd-filters record)
- (define socket-filters
- (if (and (opensmtpd-configuration-socket record)
- (opensmtpd-socket-filters
- (opensmtpd-configuration-socket record)))
- (opensmtpd-socket-filters (opensmtpd-configuration-socket record))
- '()))
- (define list-of-interfaces
- (if (opensmtpd-configuration-interfaces record)
- (opensmtpd-configuration-interfaces record)
- '()))
- (delete-duplicates
- (append
- (remove boolean?
- (map-in-order
- ;; get the filters found in the <listen-on-record>s
- (lambda (interface-or-socket-record)
- (if (and
- (opensmtpd-interface-filters interface-or-socket-record)
- (= 1 (length (opensmtpd-interface-filters
- interface-or-socket-record))))
- ;; this next line returns an <opensmtpd-interface>
- (car (opensmtpd-interface-filters
- interface-or-socket-record))
- ;; this next line returns a filter chain.
- (opensmtpd-interface-filters interface-or-socket-record)))
- list-of-interfaces))
- socket-filters)))
- (define (flatten . lst)
- "Return a list that recursively concatenates all sub-lists of LST."
- (define (flatten1 head out)
- (if (list? head)
- (fold-right flatten1 out head)
- (cons head out)))
- (fold-right flatten1 '() lst))
- ;; This function takes in a record, or list, or anything, and returns
- ;; a list of <opensmtpd-table>s assuming the thing you passed into it had
- ;; any <opensmtpd-table>s.
- ;;
- ;; is object record? call func on it's fieldnames
- ;; is object list? loop through it's fieldnames calling func on it's records
- ;; is object #f or string? or '()? -> #f
- (define (get-opensmtpd-tables value)
- (delete-duplicates
- (remove boolean?
- (flatten ;; turn (list '(1) '(2 '(3))) -> '(1 2 3)
- (cond ((opensmtpd-table? value)
- value)
- ((record? value)
- (let* ((record-type (record-type-descriptor value))
- (list-of-record-fieldnames
- (record-type-fields record-type)))
- (map (lambda (fieldname)
- (get-opensmtpd-tables
- ((record-accessor record-type fieldname)
- value)))
- list-of-record-fieldnames)))
- ((and (list? value) (not (null? value)))
- (map get-opensmtpd-tables value))
- (else #f))))))
- (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
- (cond ((not (list? list-of-records))
- (record->string list-of-records))
- (else
- (let loop ((list list-of-records))
- (if (null? list)
- ""
- (string-append
- (record->string (car list))
- (loop (cdr list)))))))))
- (define (opensmtpd-configuration->string record)
- ;; should I use this named let, or should I give this a name, or
- ;; not use it at all...
- ;; eg:
- ;; (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-smtp opensmtpd-smtp->string)
- ;; (cons opensmtpd-configuration-srs opensmtpd-srs->string))])
- ;; (if (null? list)
- ;; ""
- ;; (string-append
- ;; (opensmtpd-configuration-fieldname->string record
- ;; (caar list)
- ;; (cdar list))
- ;; (loop (cdr list)))))
- (string-append
- (opensmtpd-configuration-fieldname->string
- record opensmtpd-configuration-bounce
- (lambda (%bounce)
- (if %bounce
- (list-of-strings->string %bounce)
- "")))
- (opensmtpd-configuration-fieldname->string record
- opensmtpd-configuration-smtp
- opensmtpd-smtp->string)
- (opensmtpd-configuration-fieldname->string
- record
- opensmtpd-configuration-srs
- opensmtpd-configuration-srs->string)
- (opensmtpd-configuration-fieldname->string
- record
- opensmtpd-configuration-queue
- opensmtpd-configuration-queue->string)
- ;; write out the mta-max-deferred
- (opensmtpd-configuration-fieldname->string
- record opensmtpd-configuration-mta-max-deferred
- (lambda (var)
- (string-append "mta max-deferred "
- (number->string
- (opensmtpd-configuration-mta-max-deferred record))
- "\n")))
- ;;write out all the tables
- (opensmtpd-configuration-fieldname->string record get-opensmtpd-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 get-opensmtpd-pkis
- opensmtpd-pki->string)
- ;; write all of the interface and socket records
- (opensmtpd-configuration-fieldname->string
- record
- opensmtpd-configuration-interfaces
- opensmtpd-interface->string)
- (opensmtpd-configuration-fieldname->string record
- opensmtpd-configuration-socket
- opensmtpd-socket->string)
- ;; write all the actions
- (opensmtpd-configuration-fieldname->string record get-opensmtpd-actions
- opensmtpd-action->string)
- ;; write all of the matches
- (opensmtpd-configuration-fieldname->string record
- opensmtpd-configuration-matches
- opensmtpd-match->string)))
- ;; 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)))
- (define (opensmtpd-configuration->mixed-text-file record)
- (apply mixed-text-file "smtpd.conf"
- (flatten (list
- ;; write out the includes
- (opensmtpd-configuration-fieldname->string
- record
- opensmtpd-configuration-includes
- opensmtpd-configuration-includes->string)
- ;; TODO should I change the below line of code into these
- ;; two lines of code?
- ;;(opensmtpd-configuration-fieldname->string
- ;; record get-opensmtpd-filters-and-filter-phases
- ;; opensmtpd-filter-and-filter-phase->string)
- ;;(opensmtpd-configuration-fieldname->string
- ;; record get-opensmtpd-filter-chains
- ;; opensmtpd-filter-chain->string)
- ;; write out all the filters
- (opensmtpd-filters->list-of-strings-and-gexps
- (get-opensmtpd-filters record))
- (opensmtpd-configuration->string record)))))
- (define %default-opensmtpd-config-file
- (plain-file "smtpd.conf" "
- listen on lo
- action inbound mbox
- match for local action inbound
- action outbound relay
- match from local for any action outbound
- "))
- (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)))))
- ;; TODO why does the below NOT work?
- ;(define (opensmtpd-shepherd-service config)
- ; (match-lambda
- ; (($ <opensmtpd-configuration> package config-file)
- ; (list (shepherd-service
- ; (provision '(smtpd))
- ; (requirement '(loopback))
- ; (documentation "Run the OpenSMTPD daemon.")
- ; (start (let ((smtpd (file-append package "/sbin/smtpd")))
- ; #~(make-forkexec-constructor
- ; (list #$smtpd "-f" (or #$config-file
- ; #$(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 "checking syntax of "
- (or
- #$config-file
- #$configuration)
- "\n"))
- (system* #$smtpd "-nf"
- (or
- #$config-file
- #$configuration)))))
- ;; TODO why does this not work?
- ;(define (opensmtpd-activation config)
- ; (match-lambda
- ; (($ <opensmtpd-configuration> package config-file)
- ; (let ((smtpd (file-append package "/sbin/smtpd"))
- ; (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 "checking syntax of "
- ; (or
- ; #$config-file
- ; #$configuration)
- ; "\n")))))))
- (define %opensmtpd-pam-services
- (list (unix-pam-service "smtpd")))
- (define opensmtpd-set-gids
- (match-lambda
- (($ <opensmtpd-configuration> package config-file set-gids?)
- (if set-gids?
- (list
- (setuid-program
- (program (file-append package "/sbin/smtpctl"))
- (setuid? #false)
- (setgid? #true)
- (group "smtpq"))
- (setuid-program
- (program (file-append package "/sbin/sendmail"))
- (setuid? #false)
- (setgid? #true)
- (group "smtpq"))
- (setuid-program
- (program (file-append package "/sbin/send-mail"))
- (setuid? #false)
- (setgid? #true)
- (group "smtpq"))
- (setuid-program
- (program (file-append package "/sbin/makemap"))
- (setuid? #false)
- (setgid? #true)
- (group "smtpq"))
- (setuid-program
- (program (file-append package "/sbin/mailq"))
- (setuid? #false)
- (setgid? #true)
- (group "smtpq"))
- (setuid-program
- (program (file-append package "/sbin/newaliases"))
- (setuid? #false)
- (setgid? #true)
- (group "smtpq")))
- '()))))
- (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)
- (service-extension setuid-program-service-type
- opensmtpd-set-gids)))
- (description "Run the OpenSMTPD, a lightweight @acronym{SMTP, Simple Mail
- Transfer Protocol} server.")))
- ;;;
- ;;; mail aliases.
- ;;;
- (define (mail-aliases-etc aliases)
- `(("aliases" ,(plain-file "aliases"
- ;; Ideally we'd use a format string like
- ;; "~:{~a: ~{~a~^,~}\n~}", but it gives a
- ;; warning that I can't figure out how to fix,
- ;; so we'll just use string-join below instead.
- (format #f "~:{~a: ~a\n~}"
- (map (match-lambda
- ((alias addresses ...)
- (list alias (string-join addresses ","))))
- aliases))))))
- (define mail-aliases-service-type
- (service-type
- (name 'mail-aliases)
- (extensions
- (list (service-extension etc-service-type mail-aliases-etc)))
- (compose concatenate)
- (extend append)
- (description "Provide a @file{/etc/aliases} file---an email alias
- database---computed from the given alias list.")))
- ;;;
- ;;; Exim.
- ;;;
- (define-record-type* <exim-configuration> exim-configuration
- make-exim-configuration
- exim-configuration?
- (package exim-configuration-package ;file-like
- (default exim))
- (config-file exim-configuration-config-file ;file-like
- (default #f)))
- (define %exim-accounts
- (list (user-group
- (name "exim")
- (system? #t))
- (user-account
- (name "exim")
- (group "exim")
- (system? #t)
- (comment "Exim Daemon")
- (home-directory "/var/empty")
- (shell (file-append shadow "/sbin/nologin")))))
- (define (exim-computed-config-file package config-file)
- (computed-file "exim.conf"
- #~(call-with-output-file #$output
- (lambda (port)
- (format port "
- exim_user = exim
- exim_group = exim
- .include ~a"
- #$(or config-file
- (file-append package "/etc/exim.conf")))))))
- (define exim-shepherd-service
- (match-lambda
- (($ <exim-configuration> package config-file)
- (list (shepherd-service
- (provision '(exim mta))
- (documentation "Run the exim daemon.")
- (requirement '(networking))
- (start #~(make-forkexec-constructor
- '(#$(file-append package "/bin/exim")
- "-bd" "-v" "-C"
- #$(exim-computed-config-file package config-file))))
- (stop #~(make-kill-destructor)))))))
- (define exim-activation
- (match-lambda
- (($ <exim-configuration> package config-file)
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils))
- (let ((uid (passwd:uid (getpw "exim")))
- (gid (group:gid (getgr "exim"))))
- (mkdir-p "/var/spool/exim")
- (chown "/var/spool/exim" uid gid))
- (zero? (system* #$(file-append package "/bin/exim")
- "-bV" "-C" #$(exim-computed-config-file package config-file))))))))
- (define exim-profile
- (compose list exim-configuration-package))
- (define exim-service-type
- (service-type
- (name 'exim)
- (extensions
- (list (service-extension shepherd-root-service-type exim-shepherd-service)
- (service-extension account-service-type (const %exim-accounts))
- (service-extension activation-service-type exim-activation)
- (service-extension profile-service-type exim-profile)
- (service-extension mail-aliases-service-type (const '()))))
- (description "Run the Exim mail transfer agent (MTA).")))
- ;;;
- ;;; GNU Mailutils IMAP4 Daemon.
- ;;;
- (define %default-imap4d-config-file
- (plain-file "imap4d.conf" "server localhost {};\n"))
- (define-record-type* <imap4d-configuration>
- imap4d-configuration make-imap4d-configuration imap4d-configuration?
- (package imap4d-configuration-package
- (default mailutils))
- (config-file imap4d-configuration-config-file
- (default %default-imap4d-config-file)))
- (define imap4d-shepherd-service
- (match-lambda
- (($ <imap4d-configuration> package config-file)
- (list (shepherd-service
- (provision '(imap4d))
- (requirement '(networking syslogd))
- (documentation "Run the imap4d daemon.")
- (start (let ((imap4d (file-append package "/sbin/imap4d")))
- #~(make-forkexec-constructor
- (list #$imap4d "--daemon" "--foreground"
- "--config-file" #$config-file))))
- (stop #~(make-kill-destructor)))))))
- (define imap4d-service-type
- (service-type
- (name 'imap4d)
- (description
- "Run the GNU @command{imap4d} to serve e-mail messages through IMAP.")
- (extensions
- (list (service-extension
- shepherd-root-service-type imap4d-shepherd-service)))
- (default-value (imap4d-configuration))))
- ;;;
- ;;; Radicale.
- ;;;
- (define-record-type* <radicale-configuration>
- radicale-configuration make-radicale-configuration
- radicale-configuration?
- (package radicale-configuration-package
- (default radicale))
- (config-file radicale-configuration-config-file
- (default %default-radicale-config-file)))
- (define %default-radicale-config-file
- (plain-file "radicale.conf" "
- [auth]
- type = htpasswd
- htpasswd_filename = /var/lib/radicale/users
- htpasswd_encryption = plain
- [server]
- hosts = localhost:5232"))
- (define %radicale-accounts
- (list (user-group
- (name "radicale")
- (system? #t))
- (user-account
- (name "radicale")
- (group "radicale")
- (system? #t)
- (comment "Radicale Daemon")
- (home-directory "/var/empty")
- (shell (file-append shadow "/sbin/nologin")))))
- (define radicale-shepherd-service
- (match-lambda
- (($ <radicale-configuration> package config-file)
- (list (shepherd-service
- (provision '(radicale))
- (documentation "Run the radicale daemon.")
- (requirement '(networking))
- (start #~(make-forkexec-constructor
- (list #$(file-append package "/bin/radicale")
- "-C" #$config-file)
- #:user "radicale"
- #:group "radicale"))
- (stop #~(make-kill-destructor)))))))
- (define radicale-activation
- (match-lambda
- (($ <radicale-configuration> package config-file)
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils))
- (let ((uid (passwd:uid (getpw "radicale")))
- (gid (group:gid (getgr "radicale"))))
- (mkdir-p "/var/lib/radicale/collections")
- (chown "/var/lib/radicale" uid gid)
- (chown "/var/lib/radicale/collections" uid gid)
- (chmod "/var/lib/radicale" #o700)))))))
- (define radicale-service-type
- (service-type
- (name 'radicale)
- (description "Run radicale, a small CalDAV and CardDAV server.")
- (extensions
- (list (service-extension shepherd-root-service-type radicale-shepherd-service)
- (service-extension account-service-type (const %radicale-accounts))
- (service-extension activation-service-type radicale-activation)))
- (default-value (radicale-configuration))))
|