TITLE MAISER TOPS-20 SMTP mail server

TITLE MAISER TOPS-20 SMTP mail server
SUBTTL Written by Mark Crispin - November 1982

; Copyright 1982-2007 Mark Crispin, Bainbridge Island, WA
; All rights reserved

; Version components

MLSWHO==0 ; who last edited MAISER (0=developers)
MLSVER==7 ; MAISER's release version (matches monitor's)
MLSMIN==1 ; MAISER's minor version
MLSEDT==^D202 ; MAISER's edit version

SEARCH MACSYM,MONSYM ; system definitions
SALL ; suppress macro expansions
.DIRECTIVE FLBLST ; sane listings for ASCIZ, etc.
.TEXT "/NOINITIAL" ; suppress loading of JOBDAT
.TEXT "MAISER/SAVE" ; save as MAISER.EXE
.TEXT "/SYMSEG:PSECT:CODE" ; put symbol table and patch area in CODE
.REQUIRE HSTNAM ; host name routines
.REQUIRE WAKEUP ; MMailr wakeup routine
.REQUIRE SYS:MACREL ; MACSYM support routines
IFNDEF OT%822,OT%822==:1

; MAISER is the server to receive electronic mail from other systems via
; a network. It implements the server half of SMTP (Simple Mail Transfer
; Protocol), the DoD standard electronic mail interchange protocol defined
; in RFC 2821, and documented online on the Internet as:
; ftp://ftp.ietf.org/rfc/rfc2821.txt
;
; While nominally MAISER will be used layered on top of the DoD transport
; protocols (TCP/IP) in the Internet environment, it has been designed so
; that this is not necessary. All I/O is done via primary I/O, and the
; Internet system call dependencies have been kept to a minimum so that the
; server can essentially support any network.
;
; MAISER runs on TOPS-20 release 5.3 and later monitors. MAISER will not
; run on Tenex; the "Twenex" operating system is a figment of the imagination
; of certain individuals. There ain't no such thing as a free lunch.

; Routines invoked externally

EXTERN $GTPRO,$GTNAM,$GTLCL,$GTHNS,$GTHSN,$GTHRL,$GTHWL,$RMREL,$GTHST
EXTERN $WAKE
EXTERN $CHSSN,$CHSNS,$GTCAN
SUBTTL Assembly options

IFNDEF FT2821,<FT2821==1> ; RFC 2821 (as opposed to RFC 822) compliance
IFNDEF TIMOCT,<TIMOCT==^D20> ; number of 15-second ticks of inactivity
; allowed before autologout
IFNDEF MAXSIZE,<MAXSIZE=^D65536> ; maximum size message permitted
IFNDEF FTSTALL,<FTSTALL==1> ; stall on certain errors to delay hackers

IFN FT2821,<FTDATABUG==0> ; forbidden to set this if RFC compliant
IFNDEF FTUNIXBUG,<FTUNIXBUG==0> ; non-zero to compensate for stupid UNIX SMTP
; servers that think that Internet newline is
; bare LF. Not strictly RFC compliant, but
; not forbidden either
IFNDEF FTDATABUG,<FTDATABUG==0> ; non-zero to accept <LF>.<LF> as equivalent
; to <CRLF>.<CRLF> Forbidden by RFC 2821
IF2,<IFN FTDATABUG,< ;; don't remove this
PRINTX %You have configured this server to be in VIOLATION of the SMTP
PRINTX % standard. Refer to RFC 2821, section 4.1.1.4 (on page 33):
PRINTX % The custom of accepting lines ending only in <LF>, as a concession to
PRINTX % non-conforming behavior on the part of some UNIX systems, has proven
PRINTX % to cause more interoperability problems than it solves, and SMTP
PRINTX % server systems MUST NOT do this, even in the name of improved
PRINTX % robustness. In particular, the sequence "<LF>.<LF>" (bare line
PRINTX % feeds, without carriage returns) MUST NOT be treated as equivalent to
PRINTX % <CRLF>.<CRLF> as the end of mail data indication.
>>

; From here on down probably do not need site-specific customization

IFNDEF DATORG,<DATORG==3000> ; data on page 3
IFNDEF PAGORG,<PAGORG==100000> ; paged data on page 100
IFNDEF CODORG,<CODORG==400000> ; code on page 400

; These fields have required minimum sizes established by RFC 2821. Someday
; these ought to be made to be dynamically assigned out of free storage.

IFNDEF TXTLEN,<TXTLEN==2*^D512> ; length of command line (512 required minimum)
IFNDEF ADLLEN,<ADLLEN==2*^D256> ; length of an a-d-l (256 required minimum)
IFNDEF USRNML,<USRNML==2*^D64> ; length of a user name (64 required minimum)
IFNDEF HSTNML,<HSTNML==2*^D255> ; length of a host name (255 required minimum)
; (formerly 64 in RFC 821)
; no limit to text line (1000 required minumum)

IFNDEF GFKFKS,<GFKFKS==1> ; number of forks gotten by GFRKS%
IFNDEF PDLLEN,<PDLLEN==^D2000> ; stack length
SUBTTL Definitions

; AC definitions

FL==:0 ; flags
A=:1 ; JSYS, temporary ACs
B=:2
C=:3
D=:4
E=:5 ; non-JSYS temporary ACs
F=:6
G=:7
H=:10
P=:17 ; stack pointer

; Flags

MSKSTR F%HLO,FL,1B0 ; HELO command seen
MSKSTR F%FRM,FL,1B1 ; have a FROM specification
MSKSTR F%TO,FL,1B2 ; have a TO specification
MSKSTR F%EOL,FL,1B3 ; EOL seen
MSKSTR F%ELP,FL,1B4 ; buffer began with EOL
MSKSTR F%EXP,FL,1B5 ; EXPN vs. VRFY command
MSKSTR F%DOP,FL,3B7 ; delivery option code (see DOPTAB)
MSKSTR F%NOK,FL,1B8 ; PARMBX allows null path (for MAIL FROM:)
MSKSTR F%MOK,FL,1B9 ; PARMBX allows null domain (for RCPT TO:)
MSKSTR F%VLH,FL,1B10 ; given host name validated
MSKSTR F%REE,FL,1B11 ; reenter
MSKSTR F%NVT,FL,1B12 ; on a network terminal, must log out when done
MSKSTR F%RFS,FL,1B13 ; found a user who's refusing sends
MSKSTR F%PRO,FL,3B15 ; transport protocol:
P%UNK==0 ; unknown
P%TCP==1 ; TCP
P%CHA==2 ; Chaosnet
P%MAX==3 ; Max number of possible transport protocols
MSKSTR F%QOT,FL,1B16 ; doing quoting
MSKSTR F%JFN,FL,1B17 ; primary I/O is a JFN that must be closed
MSKSTR F%NAH,FL,1B18 ; not validated name
MSKSTR F%EHL,FL,1B19 ; EHLO command seen

; Here's a macro that really should be in MACSYM!

DEFINE ANNJE. <..TAGF (ERJMP,)>

; Fatal assembly error macro

DEFINE .FATAL (MESSAGE) <
PASS2
PRINTX ?'MESSAGE
END
>;DEFINE .FATAL

CHLPR==:"(" ; work around various macro lossages
CHRPR==:")"
CHLAB==:"<"
CHRAB==:">"
CHQOT==:""""

SUBTTL GTDOM% definitions

IFNDEF GTDOM%,<
OPDEF GTDOM% [JSYS 765]

GD%LDO==:1B0 ; local data only (no resolve)
GD%MBA==:1B1 ; must be authoritative (don't use cache)
GD%RBK==:1B6 ; resolve in background
GD%EMO==:1B12 ; exact match only
GD%RAI==:1B13 ; uppercase output name
GD%QCL==:1B14 ; query class specified
GD%STA==:1B16 ; want status code in AC1 for marginal success
.GTDX0==:0 ; total success
.GTDXN==:1 ; data not found in namespace (authoritative)
.GTDXT==:2 ; timeout, any flavor
.GTDXF==:3 ; namespace is corrupt

GTDWT==:12 ; resolver wait function
GTDPN==:14 ; get primary name and IP address
GTDMX==:15 ; get MX (mail relay) data
.GTDLN==:0 ; length of argblk (inclusive)
.GTDTC==:1 ; QTYPE (ignored for .GTDMX),,QCLASS
.GTDBC==:2 ; length of output string buffer
.GTDNM==:3 ; canonicalized name on return
.GTDRD==:4 ; returned data begins here
.GTDML==:5 ; minimum length of argblock (words)
GTDAA==:16 ; authenticate address
GTDRR==:17 ; get arbitrary RR (MIT formatted RRs)
>;IFNDEF GTDOM%

SUBTTL Impure storage

LOC 20 ; enter low memory

FATACS: BLOCK 20 ; save of fatal ACs
JBUUO: BLOCK 1 ; LUUO saved here
JB41: JSR UUOPC ; instruction executed on LUUO
UUOACS: BLOCK 20 ; save of UUO ACs

LOC 116
JBSYM: BLOCK 1 ; symbol table pointer
JBUSY: BLOCK 1 ; place holder

RELOC ; enter low segment

; Anti-spam settings, set non-zero to enable

$ASRES: 0 ; foreign address must resolve to a name
$ASRVH: 0 ; HELO/EHLO validation
$ASRCP: 0 ; disable RCPT address validation
$ASVFY: 0 ; disable VRFY, implies $ASEXP
$ASEXP: 0 ; disable EXPN
$ASGRP: 0 ; greeting pause
$ASHLO: 0 ; reject localhost, mail.local in HELO/EHLO
$ASCBI: 0 ; clear input buffer at each comand

; UUO handler

UUOPC: BLOCK 1 ; PC of LUUO
MOVEM 17,FATACS+17 ; save ACs in FATACS for debugging
MOVEI 17,FATACS ; save from 0 => FATACS
BLT 17,FATACS+16 ; ...to 16 => FATACS+16
MOVE 17,FATACS+17 ; restore AC17
TMSG <421-Illegal instruction >
MOVX A,.PRIOU ; output the losing LUUO
MOVE B,.JBUUO
MOVX C,^D8 ; in octal
NOUT%
NOP
TMSG < at >
HRRZ F,UUOPC ; output PC which lost
CALL SYMOUT
JRST IMPERR ; indicate impossible error and die

; Data area

.PSECT DATA,DATORG ; enter data area

PDL: BLOCK PDLLEN ; stack
BUFFER: BLOCK <TXTLEN/5>+1 ; general purpose buffer
GTJBLK: BLOCK <.JIBAT-.JITNO+1> ; GETJI% stores data here
TMPBUF: BLOCK 30 ; temporary buffer
IN2ACS: BLOCK 3 ; save area for ACs A-C, level 2
LEV1PC: BLOCK 1 ; PSI level 1 PC
LEV2PC: BLOCK 1 ; PSI level 2 PC
LEV3PC: BLOCK 1 ; PSI level 3 PC
TIMOUT: BLOCK 1 ; timeout count

INICBG==. ; first location cleared at once-only init
MYUSRN: BLOCK 1 ; my user number
; Following two lines must be in this order
MYJOBN: BLOCK 1 ; my job number
MYTTYN: BLOCK 1 ; my TTY number
; end of critical order data
MBXFRK: BLOCK 1 ; mailbox fork
MBXWIN: BLOCK 1 ; current window pointer into mailbox

; Host name/address storage

LCLHNO: BLOCK 1 ; local host address from STAT%
LCLHNC: BLOCK 1 ; local host address (in canonical form)
LCLHST: BLOCK <HSTNML/5>+1 ; local host name
FRNHNO: BLOCK 1 ; foreign host address from STAT%
FRNHST: BLOCK <HSTNML/5>+1 ; foreign host name from FRNHNO
FRNHNM: BLOCK <HSTNML/5>+1 ; foreign host name from HELO negotiation

RSTCBG==. ; first location cleared at RSET time
MLQJFN: BLOCK 1 ; queued mail file JFN
MBXBEG==. ; first mailbox location
ATDOML: BLOCK <ADLLEN/5>+1 ; at domain list specification
MAILBX: BLOCK <USRNML/5>+1 ; mailbox specification
DOMAIN: BLOCK <HSTNML/5>+1 ; domain specification
MBXEND==.-1 ; last path location
RSTCEN==.-1 ; last location cleared at RSET time
INICEN==.-1 ; last location cleared at once-only init

.ENDPS

; Paged data area

.PSECT DATPAG,PAGORG ; data pages

MBXPAG: BLOCK 2000 ; for mailing list forwarding pointers
WINPAG: BLOCK 2000 ; for mailing list forwarding strings

.ENDPS
SUBTTL Start of program

.PSECT CODE,CODORG ; pure code

; Entry vector

EVEC: JRST MAISER ; START address
JRST MAIREE ; REENTER address
<FLD MLSWHO,VI%WHO>!<FLD MLSVER,VI%MAJ>!<FLD MLSMIN,VI%MIN>!<FLD MLSEDT,VI%EDN>!VI%DEC
EVECL==.-EVEC

MAISER: TDZA FL,FL ; clear flags
MAIREE: MOVX FL,F%REE
RESET% ; flush all I/O
MOVE P,[IOWD PDLLEN,PDL] ; init stack context
SETZM INICBG ; clear once-only area
MOVE A,[INICBG,,INICBG+1]
BLT A,INICEN

; It looks like a bad idea to run with capabilities, and it is. However, a
; system which runs with account validation may cause problems when trying
; to write the queued mail file. We also want to avoid possible problems
; with protections or quotas in the queued mail directory.

MOVX A,.FHSLF ; get my capabilities
RPCAP%
IOR C,B ; enable as many capabilities as we can
EPCAP%
ERJMP .+1 ; ignore possible ACJ ITRAP
SETZM TIMOCT ; reset timeout count
CALL SETPSI ; set up PSIs

; See if top-level fork, and if so assume we're a network server on an NVT.
; Note that all I/O is done via primary I/O. This allows several ways we can
; be set up, e.g.:
; . traditional CRJOB% style running as a job on an NVT
; . on a physical terminal, as in a "TTY network" environment.
; . with primary I/O remapped to the network JFN's.

GJINF% ; get job info
MOVEM A,MYUSRN ; save my user number
DMOVEM C,MYJOBN ; save job number/TTY number for later use
IFGE. D ; can be NVT server only if attached
MOVX A,.FHSLF ; see what my primary I/O looks like. If
GPJFN% ; AC2 isn't -1 (.CTTRM,,.CTTRM), then we
..TAGF (<AOJN B,>,) ; can assume setup process init'd TTY
MOVX A,.FHTOP ; top fork
SETZ B, ; no handles or status
MOVE C,[-<<GFKFKS*3>+1>,,BUFFER] ; fork structure area
GFRKS% ; look at fork structure
ERJMP .+1 ; ignore error (probably GFKSX1)
HRRZ A,BUFFER+1 ; get the top fork's handle
CAXE A,.FHSLF ; same as me?
IFSKP.
MOVX A,.PRIIN ; set terminal type to ideal
MOVX B,.TTIDL
STTYP%
MOVE B,[TT%MFF!TT%TAB!TT%LCA!TT%WKF!TT%WKN!TT%WKP!TT%WKA!<FLD .TTASC,TT%DAM>!<FLD .TTLDX,TT%DUM>]
SFMOD% ; has formfeed, tab, lowercase, all wakeup,
STPAR% ; no translate ASCII, line half-duplex
DMOVE B,[BYTE (2)2,2,2,0,2,2,2,2,2,2,2,2,2,2,2,2,2,2
BYTE (2)2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2]
SFCOC% ; disable all echoing on controls
MOVX A,TL%CRO!TL%COR!TL%SAB!.RHALF ; break and refuse links
MOVX B,.RHALF
TLINK%
ERCAL FATAL
MOVX A,.PRIIN ; refuse system messages
MOVX B,.MOSNT
MOVX C,.MOSMN
MTOPR%
ERCAL FATAL
MOVE A,[SIXBIT/MAISER/] ; set our name
SETNM%
TQO F%NVT ; flag an NVT server
ENDIF.
ENDIF.

; Get host info

CALL GETTCP ; get TCP local/foreign host poop
IFNSK.
CALL GETCHA ; failed, try Chaosnet
ANNSK.
;; calls for other networks go here
HRROI A,LCLHST ; otherwise get local host name any way we can
CALL $GTLCL
IFNSK.
TMSG <421-Unable to get local host name>
JRST IMPERR
ENDIF.
HRROI A,LCLHST ; remove relative relative domain from name
CALL $RMREL
ENDIF.

; See if SYSTEM:DISABLE-MAIL.FLAG exists, and if so hang up

MOVX A,GJ%SHT!GJ%OLD ; check if mail disabled now
HRROI B,[ASCIZ/SYSTEM:DISABLE-MAIL.FLAG/]
GTJFN% ; by seeing if this magic file exists
IFNJE.
RLJFN% ; it does, flush the JFN we made
NOP
TMSG <421->
HRROI A,LCLHST ; output host name
PSOUT%
TMSG < ESMTP service is disabled, please try again later
421 >
JRST QUIT1
ENDIF.

; Here to output a banner announcing the service

SKIPE A,$ASGRP ; get the anti-spam greet pause
DISMS%
MOVX A,.PRIIN ; don't let client jump the gun either
CFIBF%
ERJMP .+1
TMSG <220 > ; start banner
HRROI A,LCLHST ; output host name
PSOUT%
TMSG < ESMTP > ; we offer ESMTP now
MOVX A,.PRIOU ; set up for primary output
LOAD B,VI%MAJ,EVEC+2 ; get major version
MOVX C,^D10 ; versions are decimal as of 7/2005
NOUT%
ERCAL FATAL
LOAD B,VI%MIN,EVEC+2 ; get minor version
IFN. B ; ignore if no minor version
MOVEI A,"." ; output delimiting dot
PBOUT%
MOVX A,.PRIOU ; now output the minor version
NOUT%
ERCAL FATAL
ENDIF.
LOAD B,VI%EDN,EVEC+2 ; get edit version
IFN. B ; ignore if no edit version
MOVX A,.CHLPR ; edit delimiter
PBOUT%
MOVX A,.PRIOU ; now output the edit version
NOUT%
ERCAL FATAL
MOVX A,.CHRPR ; edit close delimiter
PBOUT%
ENDIF.
LOAD B,VI%WHO,EVEC+2 ; get who last edited
IFN. B ; ignore if last edited by developers
MOVX A,.CHHYP ; output delimiting hyphen
PBOUT%
MOVX A,.PRIOU ; now output the who version
NOUT%
ERCAL FATAL
ENDIF.
TMSG < at >
MOVX A,.PRIOU ; output date/time
SETO B, ; time now
MOVX C,OT%DAY!OT%SPA!OT%TMZ!OT%SCL!OT%822 ; RFC 822 standard date/time
ODTIM%
ERCAL FATAL
; JRST GETCMD
SUBTTL Command loop

GETCMD: DO.
MOVX A,.PRIIN
SKIPE $ASCBI ; want to stymie streaming spammers?
CFIBF% ; yes, do so
ERJMP .+1
CALL CRLF ; terminate reply with CRLF
MOVNI A,TIMOCT ; reset timeout count
MOVEM A,TIMOUT
SETZM BUFFER ; clear out old crud in BUFFER
MOVE A,[BUFFER,,BUFFER+1]
BLT A,BUFFER+<TXTLEN/5>
MOVX A,.PRIIN ; from primary input
HRROI B,BUFFER ; pointer to command buffer
MOVX C,TXTLEN-1 ; up to this many characters
IFE FTUNIXBUG,<
MOVX D,.CHCRT ; terminate on carriage return
>;IFE FTUNIXBUG
IFN FTUNIXBUG,<
MOVX D,.CHLFD ; terminate on line feed
>;IFN FTUNIXBUG
SIN% ; read a command
ERJMP INPEOF ; finish up on error
IFE. C ; if count unsatisfied, must have seen CR
LDB A,B ; get last byte
IFE FTUNIXBUG,<
CAXN A,.CHCRT ; was it a CR?
>;IFE FTUNIXBUG
IFN FTUNIXBUG,<
CAXN A,.CHLFD ; was it a line feed?
>;IFN FTUNIXBUG
IFSKP.
TMSG <500 Line too long>
LOOP.
ENDIF.
ENDIF.
IFE FTUNIXBUG,<
PBIN% ; get expected LF
ERJMP INPEOF ; finish up on error
CAXN A,.CHLFD ; was it a line feed?
IFSKP.
TMSG <500 Line does not end with CRLF>
LOOP.
ENDIF.
>;IFE FTUNIXBUG
IFN FTUNIXBUG,<
SETO C, ; point to character before the last
ADJBP C,B
MOVE B,C ; remember that pointer
LDB C,C ; get character before the last
CAXE C,.CHCRT ; was it a CR?
IBP B ; no, line ended with bare LF then
>;IFN FTUNIXBUG
SETZB A,TIMOUT ; make command null-terminated
DPB A,B
LDB C,[POINT 7,BUFFER,34] ; make sure space or NUL
CAXE C,.CHSPC
JUMPN C,SYNERR
MOVE A,BUFFER ; get command from buffer
ANDCM A,[BYTE (7) 040,040,040,040,177] ; upper caseify
MOVSI B,-CMDTBL ; length of command table
DO.
CAME A,CMDTAB(B) ; command matches?
AOBJN B,TOP. ; try next command
ENDDO.
JRST @CMDDSP(B) ; dispatch to command
ENDDO.
SUBTTL Command table and dispatch

DEFINE COMMANDS <
; "Minimum required for an SMTP implementation" commands
CMD EHLO
CMD HELO
CMD MAIL
CMD RCPT
CMD DATA
CMD RSET
CMD NOOP
CMD QUIT
; "Optional" commands
CMD SEND
CMD SOML
CMD SAML
CMD VRFY
CMD EXPN
CMD HELP
CMD TURN
>;DEFINE COMMANDS

DEFINE CMD (CM) <ASCII/'CM'/>

CMDTAB: COMMANDS ; command names
CMDTBL==.-CMDTAB

DEFINE CMD (CM) <.'CM>

CMDDSP: COMMANDS ; command dispatch
BADCMD ; here if command not found
SUBTTL Command service routines

; HELO - HELLO: negotiate identities

EHLO: TQOA F%EHL ; flag extended
HELO: TQZ F%EHL ; not extended
TQZ <F%HLO,F%VLH> ; cancel valid HELO and host validated
JUMPE C,MISARG ; must have argument
SETZM FRNHNM
DMOVE A,[POINT 7,BUFFER+1 ; pointer to foreign host name
POINT 7,FRNHNM] ; where we store it
MOVX D,HSTNML ; length of a host name
CALL GETDOM ; get domain name
JRST SYNFLD
JUMPN C,SYNFLD ; error if not newline here
LOAD A,F%PRO ; get protocol used
CALL @VALDSP(A) ; validate HELO according to transport protocol
IFQN. F%HLO ; have a valid HELO?
TQNN F%EHL ; EHLO?
SKIPA A,[-1,,[ASCIZ/250 /]] ; HELO
HRROI A,[ASCIZ/250-/] ; EHLO
ELSE.
HRROI A,[ASCIZ/421 /] ; HELO failure reply
ENDIF.
PSOUT%
HRROI A,LCLHST ; output our name
PSOUT%
TQNN F%VLH ; host name validated?
SKIPA A,D ; no, output auxillary message
HRROI A,[ASCIZ/ - Hello/]
PSOUT%
SKIPN FRNHST ; do we know who foreign host is?
IFSKP.
TMSG <, > ; yes, prepare to output it
HRROI A,FRNHST ; output foreign host's registered name
PSOUT%
ENDIF.
JE F%HLO,,QUIT2 ; die if failed HELO
IFQN. F%EHL ; doing EHLO?
SKIPN $ASVFY ; VRFY disabled?
SKIPE $ASEXP ; EXPN disabled?
IFSKP.
TMSG <
250-EXPN>
ENDIF.
TMSG <
250-SIZE >
MOVX A,.PRIOU ; output size limit
MOVX B,MAXSIZE
MOVX C,^D10
NOUT%
ERCAL FATAL
TMSG <
250-SEND
250-SOML
250-SAML
250 HELP>
ENDIF.
JRST RSET2 ; enter RSET code

;; Dispatch table for validation per transport protocol.
;; Any mismatch here will cause an error at the definitions above on pass 2.
VALDSP: PHASE 0
P%UNK:! VALUNK ; unknown protocol
P%TCP:! VALTCP ; TCP/SMTP
P%CHA:! VALCHA ; Chaos/SMTP
REPEAT <P%MAX-.>,<VALERR> ; who knows?
DEPHASE

;; Unknown protocol, no name validation possible
VALUNK: HRROI D,[ASCIZ/ - Your name accepted but not validated/]
TQO F%HLO ; HELO is valid, name is not
RET ; that's all we can do.

;; Unrecognized F%PRO value, lose
VALERR: TMSG <421-Bad F%PRO dispatch (VALERR)>
JRST IMPERR ; "impossible" error, punt

;; Transport protocol is TCP/IP

VALTCP: SKIPE FRNHST ; got foreign host name yet?
IFSKP.
HRROI A,FRNHST ; get foreign host name
MOVE B,FRNHNO ; from foreign address
CALL $GTHNS
IFNSK.
TMSG <421-Unable to get foreign host name>
JRST IMPERR
ENDIF.
HRROI A,FRNHST ; remove relative domain from name
CALL $RMREL
CALL $GTHRL ; see if name is a literal
IFSKP.
SKIPN $ASRES ; it is, punt if we want PTR
ANSKP.
TMSG <421-We do not accept mail from unresolvable IP addresses
421 >
JRST QUIT1
ENDIF.
MOVX A,.GTDAA ; no, authenticate (in case PTR spoof)
HRROI B,FRNHST ; this name
MOVE C,FRNHNO ; must match this address
CALL $GTHST
TQO F%NAH ; name did not authenticate
ENDIF.
HRROI A,FRNHNM ; see if name is a literal
CALL $GTHRL ; parse it and return address in B
IFSKP.
CAME B,FRNHNO ; read a literal, address matches?
IFSKP.
TQO <F%HLO,F%VLH> ; yes, note host name validated
RET
ENDIF.
MOVE C,B ; in case needed to restore
HRROI A,BUFFER ; canonicalize address: get name for address
CALL $GTHNS ; (using IN-ADDR again)
IFSKP.
HRROI A,BUFFER
CALL $RMREL
HRROI A,BUFFER ; see if that name matches
HRROI B,FRNHST
STCMP%
IFE. A
TQO <F%HLO,F%VLH> ; yes, note host name validated
RET
ENDIF.
HRROI A,BUFFER ; now get the address from the name
CALL $GTHSN
MOVE B,C ; restore address after failure
ELSE.
MOVE B,C ; restore address after failure
ENDIF.

ELSE. ; not a literal, must be real host name
SKIPN $ASHLO ; want basic HELO validation?
IFSKP.
MOVE B,[POINT 7,FRNHNM]
DO.
ILDB A,B ; make sure DNS format name
CAIE A,"." ; found delimiter?
JUMPN A,TOP.
ENDDO.
IFN. A
HRROI A,FRNHNM ; reject mail.local
HRROI B,[ASCIZ/MAIL.LOCAL/]
STCMP%
ANDN. A
HRROI A,FRNHNM ; reject localhost
HRROI B,[ASCIZ/LOCALHOST.LOCALDOMAIN/]
STCMP% ; got a match?
ANDN. A
ELSE.
HRROI D,[ASCIZ/ - fix your SMTP sender/]
RET
ENDIF.
ENDIF.
HRROI A,FRNHNM ; point to her claimed foreign host name
HRROI B,FRNHST ; compare with what we think it is
STCMP% ; got a match?
IFE. A
TQO <F%HLO,F%VLH> ; yes, note host name validated
RET
ENDIF.

HRROI A,FRNHNM ; point to claimed name
CALL $GTHSN ; get its address
IFSKP.
CAME B,FRNHNO ; matches what we think?
IFSKP.
TQO <F%HLO,F%VLH> ; looks good
RET
ENDIF.
CAME B,LCLHNC ; no, claims to be me?
CAMN B,LCLHNO
IFNSK.
HRROI D,[ASCIZ/ - You can't impersonate me/]
RET
ENDIF.
MOVE H,B ; save address for later
MOVX A,.GTDAA ; authenticate address
HRROI B,FRNHNM ; from claimed name
MOVE C,FRNHNO ; and its address
CALL $GTHST
IFSKP.
TQO <F%HLO,F%VLH> ; note validated if OK
RET
ENDIF.
MOVE B,H ; get back address
ENDIF.
ENDIF.
CALLRET VALNET ; join common network validation code

;; Transport protocol is Chaosnet.

VALCHA: SKIPE FRNHST ; got foreign host name yet?
IFSKP.
HRROI A,FRNHST ; get foreign host name
MOVE B,FRNHNO ; from foreign address
CALL $CHSNS
IFNSK. ; should never happen, I guess
TMSG <421-Unable to get foreign host name>
JRST IMPERR
ENDIF.
HRROI A,FRNHST ; remove relative domain from name
CALL $RMREL
ENDIF.
HRROI A,FRNHNM ; point to her claimed foreign host name
HRROI B,FRNHST ; compare with what we think it is
STCMP% ; got a match?
IFE. A
TQO <F%HLO,F%VLH> ; yes, note host name validated
RET
ENDIF.
HRROI A,FRNHNM ; point to claimed name
CALL $CHSSN ; get its address
SETO B, ; unknown name
CAME B,FRNHNO ; matches what we think?
IFSKP.
TQO <F%HLO,F%VLH> ; looks good
RET
ENDIF.
CAME B,LCLHNC ; is it our local name?
IFSKP.
HRROI D,[ASCIZ/ - You can't impersonate me/]
RET
ENDIF.
; CALLRET VALNET ; join common network validation code

;; VALNET -- common code for validating network connections.
;; B/ address of claimed name

VALNET: IFQE. F%HLO ; if we're still not certain...
SKIPN $ASRVH ; allow uncertain HELO?
TQO F%HLO ; yes, treat as valid anyway
SKIPGE B
SKIPA D,[-1,,[ASCIZ/ - Never heard of that name/]]
HRROI D,[ASCIZ/ - You are a charlatan/]
ENDIF.
RET ; done in any case

; RSET - RESET state to initial

RSET: JUMPN C,BADARG ; can't have an argument
RSET1: TMSG <250 OK> ; acknowledge command
RSET2: SKIPN A,MLQJFN ; if a queue file open, flush its JFN
IFSKP.
TXO A,CZ%ABT ; abort it
CLOSF%
ERCAL FATAL ; why should this fail?
ENDIF.
SETZM RSTCBG ; clear reset area
MOVE A,[RSTCBG,,RSTCBG+1]
BLT A,RSTCEN
TQZ <F%FRM,F%TO> ; no more FROM or TO specification known
JRST GETCMD

; EXPN - EXPAND mailing list
; VRFY - VERIFY mailbox

EXPN: TQOA F%EXP ; flag expand
VRFY: TQZ F%EXP ; flag not expand
JUMPE C,MISARG ; must have an argument
DMOVE A,[POINT 7,BUFFER+1 ; command argument
POINT 7,MAILBX] ; where we load mailbox
MOVX D,USRNML ; maximum length of a name
ILDB C,A ; get first byte
JUMPE C,MISARG ; missing argument
CAXE C,.CHQOT ; quoted string?
IFSKP.
DO.
ILDB C,A ; get next byte to consider
CAXN C,.CHQOT ; end of quoted string?
IFSKP.
SOJL D,SYNFLD ; no, make sure field isn't too large
JUMPE C,SYNFLD ; also make sure no premature end of line
IDPB C,B ; store byte in string
LOOP. ; get next byte
ENDIF.
ENDDO.
ILDB C,A ; get final byte
JUMPN C,SYNFLD ; make sure line ends here
ELSE.
DO.
MOVEI E,(C) ; get copy of character
IDIVI E,^D32 ; E/ word to check, F/ bit to check
MOVNS F
MOVX G,1B0 ; make bit to check
LSH G,(F)
TDNE G,SPCMSK(E) ; is it a special character?
JRST SYNERR ; it is, lose
CAXE C,.CHRAB ; disallow broket and at as specials
CAIN C,"@"
JRST SYNERR
CAIN C,"\" ; quote next byte literally?
ILDB C,A ; yes, get next byte
IDPB C,B ; store byte in string
ILDB C,A ; get next byte to consider
SOJL D,SYNFLD ; field too large
JUMPN C,TOP. ; if non-null, continue parse
ENDDO.
ENDIF.
SKIPE $ASVFY ; VRFY restricted?
JRST NOVREX ; yes, VRFY or EXPN not allowed
SKIPN $ASEXP ; EXPN restricted
IFSKP.
JN F%EXP,,NOVREX ; no, disallow if EXPN
ENDIF.
IDPB C,B ; tie off string
HRROI A,MAILBX ; point to mailbox
CALL RUNMBX ; validate address
IFNSK.
SKIPE MBXFRK ; did mailbox fork run successfully?
IFSKP.
TMSG <451 Mailbox lookup process terminated abnormally>
JRST GETCMD
ENDIF.
SKIPG MBXFRK ; couldn't find mailbox fork?
JRST NOTIMP ; command not implemented
TMSG <550 No such local mailbox as ">
HRROI A,MAILBX ; output the bad mailbox
PSOUT%
TMSG <", not verified>
JRST GETCMD
ENDIF.
IFQE. F%EXP ; EXPN or VRFY?
TMSG (250 ) ; VRFY, just echo back the mailbox name given
MOVX A,.CHLAB ; MACRO still sucks after all these years
PBOUT%
HRROI A,MAILBX
PSOUT%
MOVX A,"@"
PBOUT%
HRROI A,LCLHST
PSOUT%
MOVX A,.CHRAB
PBOUT%
ELSE.
SKIPE MBXPAG+300 ; some answer must be returned
IFSKP.
TMSG <451 Mailbox lookup process returned null answer>
JRST GETCMD
ENDIF.
MOVEI D,MBXPAG+300 ; pointer to list of addresses
DO.
SKIPN C,(D) ; if end of list, return
EXIT.
SKIPN 1(D) ; is this the last item on the list?
SKIPA A,[-1,,[ASCIZ/250 /]] ; yes, no continuation
HRROI A,[ASCIZ/250-/] ; no, indicate continuation coming
PSOUT% ; output reply code and opening broket
MOVX A,.CHLAB ; MACRO still sucks after all these years
PBOUT%
TXNN C,.RHALF ; local user reply?
MOVSS C ; yes, set up as local address reply
HRRZ A,C ; get user address
CALL INFOUT ; output string from inferior
MOVX A,"@" ; output mailbox/host delimiter
PBOUT%
IFXE. C,.LHALF ; was a host specified?
HRROI A,LCLHST ; no, output local host name
PSOUT%
ELSE.
HLRZ A,C ; use specified host name
CALL INFOUT ; output string from inferior
ENDIF.
MOVX A,.CHRAB
PBOUT%
SKIPN 1(D) ; is this the last item on the list?
IFSKP. <TMSG <
>> ; no, output CRLF (don't use CALL CRLF!!)
AOJA D,TOP. ; continue until done
ENDDO.
ENDIF.
JRST GETCMD

DOPTAB: PHASE 0 ; delivery option names and F%DOP indices
D%MAIL:!ASCIZ/MAIL/ ; mail
D%SEND:!ASCIZ/SEND/ ; send
D%SOML:!ASCIZ/SOML/ ; send or mail
D%SAML:!ASCIZ/SAML/ ; send and mail
IFN <.-4>,<.FATAL Incorrect number of delivery options>
DEPHASE

; SEND - initiate SEND transaction

SEND: JUMPE C,MISARG ; must have an argument
JE F%HLO,,HLOREQ ; bad sequence if HELO not done yet
JN F%FRM,,INPROG ; bad sequence if transaction already started
MOVX A,D%SEND ; set delivery option
JRST MAKQUE ; make a queued mail file

; SOML - initiate SEND transaction, mail if not on-line

SOML: JUMPE C,MISARG ; must have an argument
JE F%HLO,,HLOREQ ; bad sequence if HELO not done yet
JN F%FRM,,INPROG ; bad sequence if transaction already started
MOVX A,D%SOML ; set delivery option
JRST MAKQUE ; make a queued mail file

; SAML - initiate SEND transaction and mail

SAML: JUMPE C,MISARG ; must have an argument
JE F%HLO,,HLOREQ ; bad sequence if HELO not done yet
JN F%FRM,,INPROG ; bad sequence if transaction already started
MOVX A,D%SAML ; set delivery option
JRST MAKQUE ; make a queued mail file

; Table of devices to queue mail to

MLQTAB: -1,,[ASCIZ/MAILQ:/] ; MAILQ: is the official directory
-1,,[ASCIZ/SYSTEM:/] ; if not, MMAILR still scans SYSTEM:
-1,,[ASCIZ/DSK:/] ; otherwise must use connected directory
MLQTBL==.-MLQTAB

; MAIL - initiate MAIL transaction

MAIL: JUMPE C,MISARG ; must have an argument
JE F%HLO,,HLOREQ ; bad sequence if HELO not done yet
JN F%FRM,,INPROG ; bad sequence if transaction already started
MOVX A,D%MAIL ; set delivery option
; JRST MAKQUE ; make a queued mail file

; Make a mailer queued request file

MAKQUE: STOR A,F%DOP ; set delivery options
MOVE A,BUFFER+1 ; get what comes after MAIL<SP>
ANDCM A,[BYTE (7) 040,040,040,040,000] ; uppercaseify if needed
CAME A,[ASCII/FROM:/] ; was it MAIL FROM:, etc.?
JRST SYNERR ; no, syntax error
MOVE A,[POINT 7,BUFFER+2] ; start parse after the colon
TQO F%NOK ; allow null mailbox
TQZ F%MOK ; if mailbox non-null, must have domain
CALL PARMBX ; parse a mailbox
JRST SYNFLD ; syntax error in mailbox
IFN. C ; extended mail?
CAXE C,.CHSPC
IFSKP.
ILDB C,A ; stupid check for SIZE=
CAIE C,"S"
CAIN C,"s"
ANNSK.
ILDB C,A
CAIE C,"I"
CAIN C,"i"
ANNSK.
ILDB C,A
CAIE C,"Z"
CAIN C,"z"
ANNSK.
ILDB C,A
CAIE C,"E"
CAIN C,"e"
ANNSK.
ILDB C,A
CAIE C,"="
ANSKP.
MOVEI C,^D10 ; read the size
NIN%
ANNJE.
CAXG B,MAXSIZE
IFSKP.
TMSG <552 Message too large: >
JRST DMPCMD
ENDIF.
LDB C,A ; make sure command ends here
ANDE. C
ELSE.
JRST SYNFLD
ENDIF.
ENDIF.
MOVSI D,-MLQTBL ; pointer to table of mail queue devices
DO.
HRROI A,TMPBUF ; pointer to name of queued mail file we build
MOVE B,MLQTAB(D) ; get device to try
SETZ C,
SOUT%
HRROI B,[ASCIZ/[--QUEUED-MAIL--].NEW-/]
SOUT% ; set up initial part of name
PUSH P,A ; save string pointer
GTAD% ; get system date/time
MOVE B,A ; now output it in octal
POP P,A
MOVX C,^D8
NOUT%
ERCAL FATAL
HRROI B,[ASCIZ/-MAISER-J/] ; add originating process name
SETZ C,
SOUT%
HRRZ B,MYJOBN ; insert job number for unique name
MOVX C,^D10 ; in decimal
NOUT%
ERCAL FATAL
HRROI B,[ASCIZ/.-1;P770000/] ; next generation, protection 770000
SETZ C,
SOUT%
MOVX A,GJ%NEW!GJ%FOU!GJ%PHY!GJ%SHT ; want new file
HRROI B,TMPBUF ; with name we build
GTJFN% ; try to get JFN on it
IFJER.
AOBJN D,TOP. ; can't do it, try alternative place
TMSG <421-Unable to get queue file - >
CALL ERROUT ; output last JSYS error
JRST IMPERR ; now die
ENDIF.
MOVEM A,MLQJFN ; save JFN for later use
MOVX B,<<FLD 7,OF%BSZ>!OF%WR> ; open for write, 7-bit bytes
OPENF%
IFJER.
MOVE A,MLQJFN ; OPENF% failed, release the JFN
RLJFN%
ERJMP .+1
SETZM MLQJFN ; forget about it
AOBJN D,TOP. ; can't do it, try alternative place
TMSG <421-Unable to open queue file - >
CALL ERROUT ; output last JSYS error
JRST IMPERR ; now die
ENDIF.
ENDDO.
SETZ C, ; make C be 0 for SOUT%'ing below
SKIPN FRNHST ; foreign host number known?
IFSKP.
MOVX B,.CHFFD ; yes, write a NET-MAIL-FROM-HOST line
BOUT%
ERCAL FATAL
HRROI B,[ASCIZ/=NET-MAIL-FROM-HOST:/]
SOUT%
ERCAL FATAL
HRROI B,FRNHST ; output host name
SOUT%
ERCAL FATAL
HRROI B,[ASCIZ/
/] ; output trailing CRLF
SOUT%
ERCAL FATAL
ENDIF.
MOVX B,.CHFFD ; write delivery options line
BOUT%
ERCAL FATAL
HRROI B,[ASCIZ/=DELIVERY-OPTIONS:/]
SOUT%
ERCAL FATAL
LOAD B,F%DOP ; get delivery options
HRROI B,DOPTAB(B)
SOUT%
ERCAL FATAL
HRROI B,[BYTE (7) .CHCRT,.CHLFD,.CHFFD]
SOUT%
ERCAL FATAL
SKIPE MAILBX ; was a proper return path specified?
IFSKP.
HRROI B,[ASCIZ/=DISCARD-ON-ERROR/]
SOUT% ; no, failures go to a black hole
ELSE.
HRROI B,[ASCIZ/=RETURN-PATH:/]
SOUT%
ERCAL FATAL
IFE FT2821,< ; forbidden in RFC 2821
SKIPN ATDOML ; is an at-domain-list defined?
IFSKP.
HRROI B,ATDOML
SOUT%
ERCAL FATAL
ENDIF.
>;IFE FT2821
MOVE B,[POINT 7,MAILBX] ; now output Mailbox
CALL MBXOUT
MOVX B,"@" ; mailbox/domain delimiter
BOUT%
ERCAL FATAL
HRROI B,DOMAIN ; output domain
SOUT%
ERCAL FATAL
HRROI B,[BYTE (7) .CHCRT,.CHLFD,.CHFFD,"_"]
SOUT% ; write sender specification
ERCAL FATAL
HRROI B,DOMAIN ; output domain
SOUT%
ERCAL FATAL
HRROI B,[BYTE (7) .CHCRT,.CHLFD]
SOUT%
ERCAL FATAL
HRROI B,MAILBX ; output mailbox
SOUT%
ERCAL FATAL
ENDIF.
HRROI B,[BYTE (7) .CHCRT,.CHLFD,.CHFFD]
SOUT%
ERCAL FATAL
TQO F%FRM ; flag "from" part of transaction complete
TMSG <250 > ; acknowlege command
LOAD A,F%DOP ; get delivery options
HRROI A,DOPTAB(A)
PSOUT%
TMSG < accepted>
IFN FT2821,<
SKIPN ATDOML
IFSKP. <TMSG <, source route discarded per RFC 2821>>
>;IFN FT2821
JRST GETCMD ; get next command

; RCPT - identify a RECIPIENT for this transaction

RCPT: JUMPE C,MISARG ; must have an argument
JE F%FRM,,MAIREQ ; bad sequence if transaction not started yet
MOVE A,BUFFER+1 ; get what comes after RCPT<SP>
ANDCM A,[BYTE (7) 040,040,000,177,177] ; uppercaseify if needed
CAME A,[ASCII/TO:/] ; was it RCPT TO:?
JRST SYNERR ; no, syntax error
MOVE A,[POINT 7,BUFFER+1,20] ; start parse after the colon
TQZ F%NOK ; do not allow null mailbox
TQO F%MOK ; if domain null, assume local host
CALL PARMBX ; parse a mailbox
JRST SYNFLD ; syntax error
JUMPN C,SYNFLD ; extended RCPT not permitted
;;; Reduce mailbox/domain name so that domain is NIL iff the address is truly
;;; local (with no "%" in the mailbox).
DO.
SKIPE DOMAIN ; domain given?
IFSKP.
HRROI A,MAILBX ; no domain specified, see if postmaster
HRROI B,[ASCIZ/POSTMASTER/]
STCMP%
IFN. A
IFN FTSTALL,<
MOVX A,^D3000 ; stall hackers
DISMS%
>;IFN FTSTALL
JRST SYNERR
ENDIF.
ELSE.
HRROI A,DOMAIN ; domain given, look up recipient host name
SETO C, ; through all naming registries
CALL $GTPRO ; get address and registry
IFNSK.
IFN FTSTALL,<
MOVX A,^D3000 ; stall hackers
DISMS%
>;IFN FTSTALL
TMSG <550 Host name ">
HRROI A,DOMAIN ; output the bad host
PSOUT%
TMSG <" unknown, recipient rejected>
JRST GETCMD
ENDIF.
MOVE D,B ; save address
HRROI A,BUFFER ; store local name out of the way
SETO B, ; want local address for this protocol
CALL $GTNAM ; get local name
IFNSK.
TMSG <421-Unable to get local host for recipient naming registry>
JRST IMPERR
ENDIF.
CAME B,D ; was destination host in fact us?
ANSKP.
MOVE A,[POINT 7,MAILBX] ; see if local mailbox wants to relay
SETZ B,
DO.
ILDB C,A ; sniff through mailbox looking for evil
CAIE C,"%"
CAIN C,"@"
MOVE B,A ; remember last "%" or "@"
JUMPN C,TOP.
ENDDO.
IFN. B ; saw a relay within local mailbox?
DPB C,B ; yes, snip off the relay name
MOVE A,[POINT 7,DOMAIN] ; now copy relay name to domain
DO.
ILDB C,B
IDPB C,A
JUMPN C,TOP.
ENDDO.
LOOP. ; reexamine the name
ENDIF.
SETZM DOMAIN ; yes, note local domain
ENDIF.
ENDDO.
SKIPE DOMAIN ; local domain?
IFSKP.
LOAD A,F%DOP ; get delivery option
CAXE A,D%SEND ; SEND?
IFSKP.
MOVX A,RC%EMO ; yes, see if local user name
HRROI B,MAILBX
RCUSR%
IFJER.
IFN FTSTALL,<
MOVX A,^D3000 ; stall hackers
DISMS%
>;IFN FTSTALL
TMSG <550-Invalid username ">
HRROI A,MAILBX ; output the bad mailbox
PSOUT%
TMSG <", recipient rejected
550 Use SOML if you're trying to do a third-party send>
JRST GETCMD
ENDIF.
IFXN. A,RC%NOM!RC%AMB ;Parsed, does it exist?
IFN FTSTALL,<
MOVX A,^D3000 ; stall hackers
DISMS%
>;IFN FTSTALL
TMSG <550-No such local user as ">
HRROI A,MAILBX ; output the bad mailbox
PSOUT%
TMSG <", recipient rejected
550 Use SOML if you're trying to send to a mailing list>
JRST GETCMD
ENDIF.
TQZ F%RFS ; no online users refusing sends yet
MOVX D,1 ; initial job number for scan
MOVE E,C ; user number to look for in E
DO.
MOVEI A,(D) ; job number to sniff at
MOVE B,[-<.JIBAT-.JITNO+1>,,GTJBLK]
MOVX C,.JITNO ; get TTY #, user #, ..., batch flag
GETJI%
IFJER.
CAXN A,GTJIX4 ; No such job?
AOJA D,TOP. ; yes, try next higher job number
TMSG <450 User ">
HRROI A,MAILBX ; output the bad mailbox
PSOUT%
TQNE F%RFS ; was there an online job refusing?
SKIPA A,[-1,,[ASCIZ/" is refusing sends/]]
HRROI A,[ASCIZ/" is not online now/]
PSOUT%
TMSG <, try again later>
JRST GETCMD
ENDIF.
SKIPE GTJBLK+<.JIBAT-.JITNO> ; is this a batch job?
AOJA D,TOP. ; yes, skip it
SKIPL A,GTJBLK ; attached to a terminal
CAME E,GTJBLK+<.JIUNO-.JITNO> ; yes, the user we want?
AOJA D,TOP. ; no to either, try next job
TXO A,.TTDES ; make it a device designator
MOVX B,.MORNT ; does user want system messages?
MTOPR%
IFNJE.
JUMPE C,ENDLP. ; found a logged in user receiving sends, done!
ENDIF.
TQO F%RFS ; found an online user who's refusing
AOJA D,TOP. ; otherwise try next job
ENDDO.
ELSE.
SKIPE $ASRCP ; OK to validate address in RCPT?
ANSKP.
TQZ F%EXP ; yes, don't expand here
HRROI A,MAILBX
CALL RUNMBX ; validate address
ANNSK.
SKIPE MBXFRK ; failed, did mailbox fork run successfully?
IFSKP.
TMSG <451 Mailbox lookup process terminated abnormally>
JRST GETCMD
ENDIF.
SKIPG MBXFRK ; is there a mailbox fork?
ANSKP.
IFN FTSTALL,<
MOVX A,^D3000 ; stall hackers
DISMS%
>;IFN FTSTALL
TMSG <550 No such local mailbox as ">
HRROI A,MAILBX ; output the bad mailbox
PSOUT%
TMSG <", recipient rejected>
JRST GETCMD
ENDIF.
ELSE.
LOAD A,F%PRO ; non-local get connection protocol
CAXE A,P%TCP ; is it TCP?
ANSKP.
CALL LCLCHK ; is foreign host local domain?
ANSKP.
HLRO A,(C) ; not local domain, get destination registry
HRROI B,[ASCIZ/TCP/]
STCMP% ; TCP destination?
IFE. A
IFN FTSTALL,<
MOVX A,^D3000 ; stall hackers
DISMS%
>;IFN FTSTALL
TMSG <550 Destination not local, recipient rejected>
JRST GETCMD
ENDIF.
HLRO A,(C) ; see if MX name
HRROI B,[ASCIZ/MX/]
STCMP%
ANDE. A
HRROI A,DOMAIN ; MX name, are we a relay for it?
CALL RLYCHK
ANSKP.
IFN FTSTALL,<
MOVX A,^D3000 ; stall hackers
DISMS%
>;IFN FTSTALL
TMSG <550 Invalid relay, recipient rejected>
JRST GETCMD
ENDIF.
SKIPE A,MLQJFN ; get JFN of queue file
IFSKP.
TMSG <421-Queue not set up in RCPT command>
JRST IMPERR
ENDIF.
SKIPN DOMAIN ; domain specified?
SKIPA B,[-1,,LCLHST] ; no, use local host as default domain
HRROI B,DOMAIN ; output destination domain
SETZ C,
SOUT%
ERCAL FATAL
HRROI B,[ASCIZ/
/]
SOUT%
ERCAL FATAL
HRROI B,MAILBX ; now output destination mailbox
SOUT%
ERCAL FATAL
HRROI B,[BYTE (7) .CHCRT,.CHLFD,.CHFFD]
SOUT%
ERCAL FATAL
TQO F%TO ; flag "to" part of transaction complete
TMSG <250 Recipient accepted> ; acknowledge
JRST GETCMD ; and get next command

; DATA - DATA for mail transaction

DATA: JUMPN C,BADARG ; must not have an argument
JE F%TO,,RCPREQ ; have FROM/TO specifications?
SETZ H, ; initially no bytes in message
SKIPE A,MLQJFN ; get JFN of queue file
IFSKP.
TMSG <421-Queue not set up in DATA command>
JRST IMPERR
ENDIF.
LOAD B,F%DOP ; get delivery option
CAXN B,D%SEND ; if SEND, don't add Received: header
IFSKP.
HRROI B,[ASCIZ/
Received: from /] ; now, write Received line
SETZ C,
SOUT%
ERCAL FATAL
HRROI B,FRNHNM ; write foreign host
SOUT%
ERCAL FATAL
HRROI B,[ASCIZ/ (/] ; start a comment
SOUT%
ERCAL FATAL
LOAD D,F%PRO ; get connection protocol
CAXE D,P%TCP ; is it TCP?
IFSKP.
IFQE. F%VLH ; yes, foreign host number validated?
HRROI A,FRNHST ; no, do we have a name from reverse lookup?
CALL $GTHRL
ANNSK.
MOVE A,MLQJFN ; have a name (as opposed to domain literal)
HRROI B,FRNHST ; output foreign host name
SOUT%
ERCAL FATAL
MOVX B,.CHSPC ; delimit with space
BOUT%
ERCAL FATAL
ENDIF.
MOVE A,[POINT 7,BUFFER]
MOVE B,FRNHNO
CALL $GTHWL ; get domain literal
SETZ B, ; tie off literal
IDPB B,A
MOVE A,MLQJFN ; write domain literal
HRROI B,BUFFER
SOUT%
ERCAL FATAL
IFQN. F%NAH ; warn if forged
HRROI B,[ASCIZ/ -- may be forged/]
SOUT%
ERCAL FATAL
ENDIF.
ELSE.
IFQE. F%VLH ; foreign host number validated?
SKIPN FRNHST ; no, real foreign host known?
SKIPA B,[-1,,[ASCIZ/not validated/]]
HRROI B,FRNHST ; output foreign host name
SOUT%
ERCAL FATAL
ENDIF.
ENDIF.
HRROI B,[ASCIZ/) by /]
SOUT%
ERCAL FATAL
HRROI B,LCLHST ; write local host
SOUT%
ERCAL FATAL
HRROI B,[ASCIZ/; /] ; default is no With specification
LOAD D,F%PRO ; get protocol used
CAXN D,P%TCP ; TCP?
HRROI B,[ASCIZ" with TCP/SMTP; "]
CAXN D,P%CHA ; Chaos?
HRROI B,[ASCIZ" with Chaos/SMTP; "]
SOUT%
ERCAL FATAL
SETO B, ; output current date/time
MOVX C,OT%DAY!OT%SPA!OT%TMZ!OT%SCL!OT%822 ; RFC 822 standard daytime
ODTIM%
ERCAL FATAL
ENDIF.
HRROI B,[ASCIZ/
/] ; now output terminating CRLF
SETZ C,
SOUT%
ERCAL FATAL
TMSG <354 Start mail input; end with <CRLF>.<CRLF>>
CALL CRLF
TQZ F%EOL ; no EOL seen on this line yet
SETO E, ; no lookahead yet
DO.
MOVNI A,TIMOCT ; reset timeout count
MOVEM A,TIMOUT
MOVE B,[POINT 7,BUFFER] ; pointer to buffer
MOVX C,TXTLEN-1 ; up to this many characters
SKIPGE A,E ; any lookahead byte?
IFSKP.
SETO E, ; yes, no lookahead now
IDPB A,B ; stash it in the buffer
SUBI C,1 ; account for it
CAXE A,.CHCRT ; was it a CR?
ANSKP. ; if so don't read anything
ELSE.
MOVX A,.PRIIN ; read a line from primary input
IFE FTDATABUG,<
MOVX D,.CHCRT ; terminate on carriage return
>;IFE FTDATABUG
IFN FTDATABUG,<
MOVX D,.CHLFD ; terminate on line feed
>;IFN FTDATABUG
SIN%
ERJMP INPEOF ; finish up on error
LDB A,B ; get last character read
ENDIF.
IFE FTDATABUG,<
CAXE A,.CHCRT ; was it a CR?
IFSKP.
PBIN% ; yes, get byte after CR
ERJMP INPEOF ; finish up on error
CAXE A,.CHLFD ; is this a real EOL?
IFSKP.
IDPB A,B ; yes, insert it in the buffer
SUBI C,1 ; account for it in the buffer
TQO F%EOL ; flag EOL seen
ELSE.
MOVE E,A ; set lookahead byte after CR
ENDIF.
ENDIF.
>;IFE FTDATABUG
IFN FTDATABUG,<
;;; This code is in direct violation of explicit text in RFC 2821 that forbids
;;; this behavior. What's worse, it creates a loophole for spammers. Don't do
;;; it.
CAXE A,.CHLFD ; was it a LF?
IFSKP.
TQO F%EOL ; flag EOL seen
SETO D, ; point to character before LF
ADJBP D,B
LDB A,D ; get that character
CAXN A,.CHCRT ; was it a CR?
IFSKP.
MOVX A,.CHCRT ; no, overwrite LF with CRLF
IDPB A,D
MOVX A,.CHLFD
IDPB A,D
SUBI C,1 ; account for it in the buffer
ENDIF.
>;IFN FTDATABUG
MOVE B,[POINT 7,BUFFER] ; buffer we read into
SUBI C,TXTLEN-1 ; negative count of bytes to output
IFQN. F%ELP ; buffer begin with EOL?
LDB A,[POINT 7,BUFFER,6] ; yes, get first byte of buffer
CAIE A,"." ; was it a period?
IFSKP.
IBP B ; yes, skip over it
ADDI C,1 ; account for it in the count
IFQN. F%EOL ; buffer end with EOL?
CAMN C,[-2] ; yes, only two bytes to output?
EXIT. ; yes, must be EOM
ENDIF.
ENDIF.
ENDIF.
MOVE A,MLQJFN ; output buffer to queue file
CAXLE H,MAXSIZE ; already exceeded limit?
IFSKP.
MOVM G,C ; get number of bytes to write
ADD H,G ; count this many bytes
CAXG H,MAXSIZE ; message too large?
SOUT% ; no - OK to write
ERCAL FATAL
ENDIF.
TQZE F%EOL ; EOL seen?
TQOA F%ELP ; yes, set EOL seen in previous buffer
TQZ F%ELP ; no EOL in previous buffer
LOOP.
ENDDO.
SETZM TIMOUT ; can't time out now
CAXG H,MAXSIZE ; message too large?
IFSKP.
TMSG <552 Message too large>
JRST RSET2 ; abort message
ENDIF.
MOVE A,MLQJFN ; yes, must be EOM
CLOSF%
ERCAL FATAL
SETZM MLQJFN ; flush the JFN
TMSG <250-Message accepted and queued for delivery
>
CALL $WAKE ; wake up MMailr
JRST RSET1 ; now do an implicit RSET

; QUIT - QUIT out of mail service

QUIT: JUMPN C,BADARG ; must not have an argument
TMSG <221 > ; start acknowledgement
QUIT1: HRROI A,LCLHST ; output our host name
PSOUT%
TMSG < Service closing transmission channel>
QUIT2: CALL CRLF
INPEOF: CALL HANGUP ; hang up the connection
JRST MAISER ; restart program

HANGUP: SETZM TIMOUT ; can't time out now
MOVE A,[.FHSLF,,.TIMAL] ; remote all pending timers
TIMER%
ERCAL FATAL
SKIPN A,MLQJFN ; if a queue file open, flush its JFN
IFSKP.
TXO A,CZ%ABT ; abort it
CLOSF%
ERJMP .+1 ; why should this fail?
SETZM MLQJFN ; flush JFN
ENDIF.
MOVX A,.PRIOU ; wait until the output happens
DOBE%
ERJMP .+1
IFQN. F%NVT ; NVT server?
DTACH% ; detach the job to prevent "Killed..." message
ERJMP .+1
SETO A, ; now log myself out
LGOUT%
ERJMP .+1
ENDIF.
IFQN. F%JFN ; JFN that needs closing?
MOVX A,.FHSLF ; yup, find out what the JFNs were
GPJFN%
ERJMP .+1
MOVE D,B ; save returned value
SETO B, ; set primary I/O back to default value
SPJFN% ; so that we can close the JFNs
ERJMP .+1
HLRZ A,D ; now close the JFNs
CLOSF%
ERJMP .+1 ; not much we can do if this fails
MOVS A,D ; don't try to close the same JFN twice,
CAMN A,D ; it belong to some other fork by now!
ANSKP. ; JFNs weren't the same, so close .PRIOU
HRRZ A,D ; close the other JFN
CLOSF%
ERJMP .+1
ENDIF.
HALTF% ; stop
RET

; NOOP - NOOP null command

NOOP: JUMPN C,BADARG ; must not have an argument
TMSG <250 OK> ; acknowledge command
JRST GETCMD

; HELP - HELP message

HELP: JUMPN C,BADARG ; must not have an argument
HRROI A,HLPMSG ; output help message
PSOUT%
JRST GETCMD

HLPMSG: ASCIZ/214-The following commands are implemented:
214- EHLO, HELO, MAIL, RCPT, DATA, RSET, NOOP, QUIT, SEND, SOML, SAML,
214- VRFY, EXPN, HELP, TURN
214 This system is running the TOPS-20 operating system/

; TURN - TURN around transaction

TURN: JUMPN C,BADARG ; must not have an argument
TMSG <250 TURN command accepted, send 220 greeting>
CALL CRLF
CALL RDRPLY ; read SMTP reply
CAME A,[ASCII/220/] ; 220 greeting?
IFSKP.
TMSG <HELO > ; yes, output HELO
HRROI A,LCLHST ; and local host name
PSOUT%
CALL CRLF
CALL RDRPLY
; *** Here would go code to support a future implementation of outgoing mail.
; The purpose of this is for situations where two-way mail interactions on
; the same connection are useful.
ENDIF.
CAMN A,[ASCII/421/] ; was last reply code a 421 hangup?
IFSKP.
TMSG <QUIT>
CALL CRLF ; no, negotiate a normal QUIT
CALL RDRPLY ; get reply for it
ENDIF.
CALL HANGUP ; hang up the connection
JRST MAISER ; restart

; Read SMTP reply from server process (for TURN command). Returns ASCII
; of reply code in A.

RDRPLY: DO.
SETZM BUFFER ; make sure no random crud here
MOVX A,.PRIIN ; from primary input
HRROI B,BUFFER ; pointer to command buffer
MOVX C,TXTLEN-1 ; up to this many characters
MOVX D,.CHCRT ; terminate on carriage return
SIN% ; read the greeting header
ERJMP INPEOF ; finish up on error
LDB A,B ; get last byte of line
DO. ; slurp up bytes until see a CRLF
CAXN A,.CHCRT ; got a CR?
IFSKP.
PBIN% ; no, read next byte
ERJMP INPEOF ; finish up on error
LOOP. ; see if this one looks good
ENDIF.
PBIN% ; get expected LF
ERJMP INPEOF ; finish up on error
CAXE A,.CHLFD ; saw LF?
LOOP. ; no, start over again
ENDDO.
LDB A,[POINT 7,BUFFER,27] ; get possible continuation byte
CAXN A,.CHHYP ; was continuation specified?
LOOP. ; yes, get new line
CAXE A,.CHSPC ; single reply seen?
CALL HANGUP ; no, something's wrong - punt
ENDDO.
MOVE A,BUFFER ; get reply code
AND A,[BYTE (7) 177,177,177,000,000] ; without text crud
RET ; return to caller
SUBTTL Subroutines

; Here to parse a mailbox specification pointed to in A. Skips if success.
; Returns a-d-l in ATDOML, mailbox in MAILBX, and domain in DOMAIN.
; F%NOK indicates that a null mailbox is allowed, to allow null return-paths
; per the SMTP specification.
; F%MOK indicates that a domain is optional, that is, the command:
; RCPT TO:<FOO>
; will be interpreted as local mailbox FOO.

PARMBX: SETZM MBXBEG ; clear previous mailbox
MOVE C,[MBXBEG,,MBXBEG+1]
BLT C,MBXEND
ILDB C,A ; get opening character
CAXE C,.CHLAB ; must be opening broket
RET ; parse fails
ILDB C,A ; get first character in path
CAXE C,.CHRAB ; is this a close broket?
IFSKP.
JN F%NOK,,PRMDUN ; yes, if null mailbox okay then return success
ENDIF.
CAIE C,"@" ; a-d-l present?
IFSKP.
MOVE B,[POINT 7,ATDOML] ; set up pointer to a-d-l
IDPB C,B ; store the starting "@"
MOVX D,ADLLEN-1 ; set up limit of domain list length
DO.
CALL GETDOM ; get a domain
RET ; syntax error in domain
CAIE C,"," ; another domain in route list?
IFSKP.
IDPB C,B ; yes, save the comma
SOJL D,R ; count the comma
ILDB C,A ; get next byte
CAIE C,"@" ; start of next at-domain?
IFSKP.
IDPB C,B ; yes, store this "@"
SOJGE D,TOP. ; count the "@"
RET ; no more space
ENDIF.
MOVX D,":" ; no, must be an RFC 788 SMTP sender, patch
DPB D,B ; a colon over the comma and exit
ELSE.
CAIE C,":" ; end of domain?
RET ; no, syntax error in domain
IDPB C,B ; save a-d-l terminator
SOJL D,R ; let's count that terminator as well
ILDB C,A ; get first character of local part
ENDIF.
ENDDO.
ENDIF.

; Here to process the local part of a mailbox, C has first character

MOVE B,[POINT 7,MAILBX] ; set up pointer to mailbox
MOVX D,USRNML ; set up maximum length of user name
CAXE C,.CHQOT ; quoted string?
IFSKP.
DO.
ILDB C,A ; yes, get next quoted byte
CAXE C,.CHQOT ; end of quoted string?
IFSKP.
ILDB C,A ; get expected at
CAIN C,"@" ; was it an at?
EXIT. ; saw an at, finished with mailbox
CAXN C,.CHRAB ; is this a close broket?
SKIPN MAILBX ; yes, was mailbox non-null?
RET ; not close broket or mailbox null, syntax err
JN F%MOK,,PRMDUN ; yes, if F%MOK then allow missing domain
RET ; syntax error
ENDIF.
CAXE C,.CHCRT ; CR or LF invalid in quoted string
CAXN C,.CHLFD
RET
CAIN C,"\" ; quote next byte literally?
ILDB C,A ; yes, get next byte
IDPB C,B ; store byte in string
SOJGE D,TOP. ; continue with next byte unless overflowed
RET ; mailbox name too long
ENDDO.
ELSE.
DO. ; parse unquoted string
MOVEI E,(C) ; get copy of character
IDIVI E,^D32 ; E/ word to check, F/bit to check
MOVNS F
MOVX G,1B0 ; make bit to check
LSH G,(F)
TDNE G,SPCMSK(E) ; is it a special character?
RET ; yes, syntax error
CAXE C,.CHRAB ; saw close broket?
IFSKP.
SKIPN MAILBX ; yes, was mailbox non-null?
RET ; no, syntax error
JN F%MOK,,PRMDUN ; if F%MOK then allow missing domain
RET ; else syntax error
ENDIF.
CAIN C,"@" ; was it an at?
IFSKP.
CAIN C,"\" ; quote next byte literally?
ILDB C,A ; yes, get next byte
IDPB C,B ; store byte in string
ILDB C,A ; get next byte to consider
SOJGE D,TOP. ; continue byte unless overflowed
RET
ENDIF.
ENDDO.
ENDIF.

; Process the destination domain and terminate the command string

MOVE B,[POINT 7,DOMAIN] ; point at domain string
MOVX D,HSTNML ; maximum length of a host name
CALL GETDOM ; get domain name
RET ; syntax error in domain
CAXE C,.CHRAB ; closing broket?
RET ; no, syntax error
SKIPE MAILBX ; mailbox required
SKIPN DOMAIN ; domain required
RET ; mailbox or domain missing
PRMDUN: ILDB C,A ; get line ending character
RETSKP

; Table of special characters

BRINI. ; initialize break mask

BRKCH. (.CHNUL,.CHSPC) ; all controls are special characters
BRKCH. (042) ; """"
BRKCH. (050,051) ; "(", ")"
BRKCH. (054) ; ","
BRKCH. (072,074) ; ":", ";", "<"
; BRKCH. (076) ; ">" commented out because processed in code
; BRKCH. (100) ; "@" commented out because processed in code
BRKCH. (133) ; "["
; BRKCH. (134) ; "\" commented out because processed in code
BRKCH. (135) ; "]"

SPCMSK: EXP W0.,W1.,W2.,W3. ; form table of special characters

; These tables are for quoting in the return-path

BRINI. ; initialize break mask

BRKCH. (.CHCNA,.CHTAB) ; CTRL/A through CTRL/I
BRKCH. (.CHVTB,.CHFFD) ; CTRL/K, CTRL/L
BRKCH. (.CHCNN,.CHSPC) ; CTRL/N through space
BRKCH. (050,051) ; "(", ")"
BRKCH. (054) ; ","
BRKCH. (072,074) ; ":", ";", "<"
BRKCH. (076) ; ">"
BRKCH. (100) ; "@"
BRKCH. (133) ; "["
BRKCH. (135) ; "]"

QOTMSK: EXP W0.,W1.,W2.,W3.

; If any of these characters are seen, they must be quoted with backslash

BRINI. ; initialize break mask

BRKCH. (.CHLFD) ; line feed
BRKCH. (.CHCRT) ; carriage return
BRKCH. (042) ; """"
BRKCH. (134) ; "\"

QT1MSK: EXP W0.,W1.,W2.,W3.

; Here to get a domain string, source pointer in A, destination pointer in B,
; maximum number of bytes in D. Skips if success with delimiter in C.

GETDOM: ILDB C,A ; get first byte of domain string
CAIE C,"#" ; monolithic number?
IFSKP.
IDPB C,B ; save indicator of moby number
SUBI D,1 ; account for character
ILDB C,A ; get first byte of number
CAIL C,"0" ; is it a number?
CAILE C,"9"
RET ; must have at least one digit
DO.
IDPB C,B ; save digit
ILDB C,A ; get subsequent digit(s)
CAIL C,"0" ; is it a number?
CAILE C,"9"
EXIT. ; no, end of domain
SOJGE D,TOP. ; else store digit and try again
RET ; string too long
ENDDO.
ELSE.
CAIE C,"[" ; dot-number?
IFSKP.
MOVX E,3 ; number of dots expected in field
DO.
IDPB C,B ; save bracket or dot
SOJL D,R ; account for character (syn err if full)
ILDB C,A ; get first byte of number
CAIL C,"0" ; is it a number?
CAILE C,"9"
RET ; must have at least one digit
DO. ; collect a number into the buffer
IDPB C,B ; save digit
ILDB C,A ; get subsequent digit(s)
CAIL C,"0" ; is it a number?
CAILE C,"9"
EXIT. ; no, leave
SOJGE D,TOP. ; numeric, store digit and try again
RET ; string too long
ENDDO.
SOJL E,ENDLP. ; if seen three dots then done
CAIN C,"." ; dot expected, did we see one?
LOOP. ; yes, store it and collect next number
RET ; else syntax error
ENDDO.
CAIE C,"]" ; closing bracket?
RET ; no, syntax error
IDPB C,B ; store closing bracket in string
SOJL D,R ; see if it makes string too long
ILDB C,A ; get delimiter byte for caller
ELSE.
CAIL C,"A" ; non-alphabetic?
CAILE C,"z"
IFSKP.
CAILE C,"Z" ; further alphabetic checking
CAIL C,"a"
IFSKP. <RET> ; non-alphabetic, lose
ELSE.
CAIL C,"0" ; numeric?
CAILE C,"9"
RET ; non-numeric, lose
ENDIF.
DO.
IDPB C,B ; store byte in string
SOJL D,R ; length check
ILDB C,A ; get next byte of string
CAIE C,"." ; dot?
CAXN C,.CHHYP ; hyphen?
LOOP. ; yes, store in string
CAIL C,"A" ; non-alphabetic?
CAILE C,"z"
IFSKP.
CAILE C,"Z" ; further alphabetic checking
CAIL C,"a"
LOOP. ; character is alphabetic, store in string
ENDIF.
CAIL C,"0" ; numeric?
CAILE C,"9"
EXIT. ; no, end of domain
LOOP. ; character is numeric, store in string
ENDDO.
LDB E,B ; get last byte in string
CAIE E,"." ; disallow null domain element
CAXN E,.CHHYP ; domain string may not end in hyphen
RET ; it did, syntax error
ENDIF.
ENDIF.
SAVEAC <B> ; leave string pointing at null
SETZ E, ; tie off string with null
IDPB E,B
RETSKP ; return success to caller

; Here to lookup a mailbox pointed to in A in the mailbox database. Skips
; if mailbox found, with pointers in MBXPAG+300.

RUNMBX: SAVEAC <A> ; don't clobber mailbox pointer
STKVAR <MBXPTR>
MOVEM A,MBXPTR ; save mailbox pointer
SKIPLE MBXFRK ; see if already a mailbox fork
IFSKP.
SETOM MBXFRK ; no, flag trying to get a mailbox fork
SETOM MBXWIN ; clear memory of cached mailbox window
MOVX A,GJ%OLD!GJ%SHT ; get JFN of forwarder
HRROI B,[ASCIZ/SYS:MMAILBOX.EXE/]
GTJFN%
ERJMP R ; not implemented if no mailbox fork
MOVEM A,MBXFRK ; save here temporarily
MOVX A,CR%CAP ; create an inferior fork
CFORK%
ERCAL FATAL
EXCH A,MBXFRK ; save fork handle, get JFN
HRL A,MBXFRK ; get prog into fork
GET%
ERCAL FATAL
ENDIF.
HRLZ A,MBXFRK ; page 0 of inferior
DMOVE B,[.FHSLF,,MBXPAG/1000 ; mapped to this fork's MBXPAG
PM%RD!PM%WR!PM%CNT+2] ; read+write access
PMAP%
ERCAL FATAL
MOVE A,[POINT 7,MBXPAG+200] ; destination
MOVE B,MBXPTR ; source address
MOVX C,-USRNML ; maximum length of an address
SOUT%
ERCAL FATAL
MOVE A,MBXFRK ; get fork handle back again
TQNN F%EXP ; need to expand?
SKIPA B,[4] ; no, just verify existance
MOVX B,3 ; expansion entry
SFRKV% ; start fork
ERCAL FATAL
WFORK% ; wait for it to halt
ERCAL FATAL
RFSTS% ; see if it finished ok
ERCAL FATAL
HLRZ A,A
CAXN A,.RFHLT ; halted normally?
IFSKP.
SETO A, ; unmap shared pages
DMOVE B,[.FHSLF,,MBXPAG/1000 ; mapped to this fork's MBXPAG
PM%CNT+2]
PMAP%
ERCAL FATAL
DMOVE B,[.FHSLF,,WINPAG/1000 ; mapped to this fork's WINPAG
PM%CNT+2]
PMAP%
ERCAL FATAL
MOVE A,MBXFRK ; flush the fork
KFORK%
ERCAL FATAL
SETZM MBXFRK
RET
ENDIF.
SKIPG MBXPAG+177 ; yes, success answer?
RET ; no, non-skip return
RETSKP ; success, skip return with fork still mapped

ENDSV.

; Output string from mailbox starting from address in A

INFOUT: SAVEAC <A,B,C> ; preserve ACs
STKVAR <MBXADR>
MOVEM A,MBXADR ; save address we're going to PSOUT% for later
LSH A,-<^D9> ; get inferior page number desired
CAMN A,MBXWIN ; already cached?
IFSKP.
MOVEM A,MBXWIN ; no, set as new mailbox window page
DMOVE B,[.FHSLF,,WINPAG/1000 ; map two pages to our WINPAG
PM%CNT!PM%RD!PM%CPY+2]
CAIN A,777 ; guard against page 777
SUBI C,1 ; oops, only one page then
HRL A,MBXFRK ; mailbox fork,,page number
PMAP%
ERCAL FATAL
ENDIF.
MOVX A,.PRIOU ; output to primary I/O
MOVE B,MBXADR ; get address back
MOVX C,<WINPAG/1000> ; page in our address space
DPB C,[POINT 9,B,26] ; set up as new address
HRLI B,(<POINT 7,>) ; make pointer
CALLRET MBXOUT ; output mailbox

ENDSV.

; Here to output mailbox with RFC822 quoting
; Accepts: A/ destination designator
; B/ mailbox source pointer
; CALL MBXOUT
; Returns +1: always

MBXOUT: SAVEAC <C,D,E,F,G>
STKVAR <SRCPTR>
MOVEM B,SRCPTR ; save source pointer
TQZ F%QOT ; initially require no quoting
MOVX B,"\" ; quote for wierd characters
MOVE G,[POINT 7,TMPBUF] ; pointer to temporary buffer
DO. ; copy to TMPBUF with \ insert and " need check
ILDB C,SRCPTR ; get character from source
ERCAL FATAL ; in case of page mapping lossage
MOVEI E,(C) ; make a copy of it to hack
IDIVI E,^D32 ; E := word to check, F := bit to check
MOVNS F
MOVX D,1B0 ; D := bit to check
LSH D,(F)
TDNE D,QOTMSK(E) ; is it a special character?
TQO F%QOT ; yes, note
TDNE D,QT1MSK(E) ; is it an wierd character?
IDPB B,G ; yes, put in wierd character quote
IDPB C,G ; now copy character
JUMPN C,TOP. ; continue
ENDDO.
MOVX B,.CHQOT
TQNE F%QOT ; need to do atomic quoting?
BOUT% ; yes, insert it
HRROI B,TMPBUF ; output buffer
SETZ C,
SOUT%
MOVX B,.CHQOT
TQNE F%QOT ; need to do atomic quoting?
BOUT% ; yes, insert it
RET

; Outputs a CRLF iff it is necessary

CRLF: SAVEAC <A,B,C>
MOVX A,.PRIOU ; use SOUTR% for non-TTY primary I/O
HRROI B,[ASCIZ/
/]
SETZ C,
SOUTR% ; this pushes the text on networks
ERJMP .+1
RET

; Convert a 32-bit quantity in A from squoze to ASCII

SQZTYO: IDIVI A,50 ; divide by 50
PUSH P,B ; save remainder, a character
SKIPE A ; if A is now zero, unwind the stack
CALL SQZTYO ; call self again, reduce A
POP P,A ; get character
ADJBP A,[POINT 7,[ASCII/ 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ.$%/],6]
LDB A,A ; convert squoze code to ASCII
PBOUT%
RET

; See if foreign host is in the same local domain

LCLCHK: SAVEAC <A,B>
JN F%NAH,,RSKP ; never local if not validated
HRROI A,LCLHST ; literal local name never same domain
CALL $GTHRL
IFNSK.
HRROI A,FRNHST ; ditto literal foreign name
CALL $GTHRL
ANNSK.
MOVE A,[POINT 7,LCLHST] ; scan for second-level domain name
CALL GETSLD
ANDN. A
MOVE B,A ; note local second-level domain
MOVE A,[POINT 7,FRNHST]
CALL GETSLD
ANDN. A
STCMP% ; compare two second-level domains
JUMPE A,R ; local if compare wins
ENDIF.
RETSKP ; not local

; Get second-level domain name pointer

GETSLD: SAVEAC <B,C,D,E>
MOVE E,A ; save original argument
SETZB B,D ; no previous pointers
DO.
ILDB C,A ; get byte from name
CAIE C,"." ; found a domain element?
IFSKP.
MOVE D,B ; yes, save previous pointer
MOVE B,A ; set new pointer
ENDIF.
JUMPN C,TOP. ; loop until done
ENDDO.
SKIPN A,D ; return pointer
SKIPN B ; no third-level domain, was there a second?
RET
MOVE A,E ; name already is second-level domain
RET

; See if we are an MX relay for a host

RLYMAX==^D10 ; maximum relays
GTDLEN==.GTDML+RLYMAX ; size of GTDOM% block
RLYBFL==RLYMAX*<<HSTNML/5>+1> ; relay buffer

RLYCHK: SAVEAC <A,B,C,D,E>
STKVAR <HOST,<GTDBLK,GTDLEN+1>,<RLYBUF,RLYBFL>>
MOVEM A,HOST
SETZM GTDBLK ; init argument block
MOVSI A,GTDBLK
HRRI A,1+GTDBLK
BLT A,GTDLEN+GTDBLK
MOVX A,GTDLEN ; block length
MOVEM A,.GTDLN+GTDBLK
MOVX A,<RLYBFL*5>-1 ; relay buffer length in chars
MOVEM A,.GTDBC+GTDBLK
MOVX A,.GTDMX ; get MX
MOVE B,HOST ; host to check
HRROI C,RLYBUF ; relays written here
MOVEI D,GTDBLK ; argument block
CALL $GTHST
IFSKP.
MOVEI E,.GTDRD+GTDBLK ; scan relay list
DO.
SKIPN A,(E) ; get next relay
EXIT.
HRROI B,LCLHST ; matches local host?
STCMP%
JUMPE A,R
MOVX A,.GTDAA ; see if this is a valid name for us
MOVE B,(E)
SETO C, ; on any of my addresses
CALL $GTHST
IFSKP. <RET> ; we are a relay for this name
AOJA E,TOP. ; consider next relay
ENDDO.
ENDIF.
RETSKP ; not a relay

ENDSV.

; Get TCP location. Skips if a TCP connection

IFNDEF TCP%TV,TCP%TV==:1B11 ; TVT argument supplied
IFNDEF $TFH,$TFH==:7 ; TCB foreign address
IFNDEF $TLH,$TLH==:10 ; TCB local address

GETTCP: IFQN. F%NVT ; NVT server?
MOVX A,TCP%TV ; argument is TVT
HRR A,MYTTYN ; our TVT number
HRROI B,$TFH ; want host number
HRROI C,FRNHNO ; put it in FRNHNO
STAT%
ERJMP R
MOVX A,TCP%TV ; argument is TVT
HRR A,MYTTYN ; our TVT number
HRROI B,$TLH ; want local host address
HRROI C,LCLHNO ; put it in LCLHNO
STAT% ; get it
ERJMP R
ELSE.
MOVX A,.PRIIN ; get foreign host from TCB
MOVX B,.TCRTW
MOVEI C,$TFH
TCOPR%
ERJMP R
MOVEM C,FRNHNO ; save foreign host address
MOVEI C,$TLH ; now get local host
TCOPR%
ERJMP R
MOVEM C,LCLHNO ; save local host address
ENDIF.
HRROI A,LCLHST ; get local host name
SETO B,
CALL $GTHNS
RET
HRROI A,LCLHST ; remove relative domain from name
CALL $RMREL
MOVEM B,LCLHNC ; save canonical local host address
CAMN B,LCLHNO ; same as local host address?
IFSKP.
HRROI A,BUFFER ; ugh, gotta look at this closer
MOVE B,LCLHNO ; get name from connection local address
CALL $GTHNS
ANSKP.
HRROI A,BUFFER ; remove relative domain from name
CALL $RMREL
HRROI A,LCLHST ; compare the names
HRROI B,BUFFER
STCMP%
ANDN. A
TMSG <421-> ; sorry, local ports not supported yet!!
HRROI A,BUFFER ; output host name
PSOUT%
TMSG < ESMTP service isn't operational yet
421 >
JRST QUIT1
ENDIF.
MOVX A,P%TCP ; set protocol to be TCP
STOR A,F%PRO
RETSKP

; Get Chaos location. Skips if a Chaosnet connection.

IFNDEF .MOFHS,<.MOFHS==34> ; foreign host# from Chaosnet JFN

GETCHA: HRROI A,[ASCIZ/CHA:/] ; see if we know what Chaosnet is
STDEV% ; (can't use .DVCHA since not constant)
ERJMP R ; guess not
MOVE D,B ; save device designator for comparison
MOVX A,.PRIIN ; see if primary I/O is Chaosnet
DVCHR% ; (assume .PRIOU is if .PRIIN is)
ERJMP R
CAME A,D ; is it Chaos/SMTP?
RET
MOVX A,.PRIIN ; yes, get foreign host number
MOVX B,.MOFHS
MTOPR%
ERCAL FATAL
MOVEM C,FRNHNO ; save host number
HRROI A,FRNHST ; look up the name
MOVE B,C ; host number
CALL $CHSNS ; use HSTNAM, just in case CHAOS uses domains
IFNSK.
TMSG <421-Unable to get foreign host name>
JRST IMPERR
ENDIF.
HRROI A,LCLHST ; get local host name and address
SETO B,
CALL $CHSNS
IFNSK.
TMSG <421-Unable to get local host name>
JRST IMPERR
ENDIF.
MOVEM B,LCLHNO ; $CHSNS returns local address too
MOVEM B,LCLHNC ; and it's always the cannonical address
MOVX A,P%CHA ; Set protocol to be Chaos
STOR A,F%PRO
TQO F%JFN ; Remember that we have to close JFN
RETSKP
SUBTTL Error handling

; Common routine called to output last error code's message

ERROUT: MOVX A,.PRIOU
HRLOI B,.FHSLF ; dumb ERSTR%
SETZ C,
ERSTR%
JRST ERRUND ; undefined error number
NOP ; can't happen
RET

ERRUND: TMSG <Undefined error >
MOVX A,.FHSLF ; get error number
GETER%
MOVX A,.PRIOU ; output it
HRRZS B ; only right half where error code is
MOVX C,^D8 ; in octal
NOUT%
ERJMP R ; ignore error here
RET

; Various SMTP errors

BADCMD: TMSG <500 Command unrecognized: >
JRST DMPCMD

SYNFLD: TMSG <500 Syntax error or field too long: >
JRST DMPCMD

SYNERR: TMSG <500 Syntax error in command: >
JRST DMPCMD

NOVREX:
IFN FT2821,< ; do different from NOTIMP if RFC 2821
TMSG <252 Sorry, we do not allow this operation>
JRST GETCMD
>;IFN FT2821
NOTIMP: TMSG <502 Command not implemented: >
JRST DMPCMD

HLOREQ: TMSG <503 HELO required before starting a transaction: >
JRST DMPCMD

MAIREQ: TMSG <503 MAIL FROM required before recipients: >
JRST DMPCMD

RCPREQ: TMSG <503 RCPT TO required before data: >
JRST DMPCMD

INPROG: TMSG <503 >
LOAD A,F%DOP ; get current delivery option
HRROI A,DOPTAB(A) ; output name of current delivery option
PSOUT%
TMSG < already in progress, must RSET first: >
JRST DMPCMD

MISARG: TMSG <500 Missing required argument: >
JRST DMPCMD

BADARG: TMSG <500 Argument given when none expected: >
DMPCMD: HRROI A,BUFFER ; output losing command
PSOUT%
JRST GETCMD

; Fatal errors arrive here

FATAL: MOVEM 17,FATACS+17 ; save ACs in FATACS for debugging
MOVEI 17,FATACS ; save from 0 => FATACS
BLT 17,FATACS+16 ; ...to 16 => FATACS+16
MOVE 17,FATACS+17 ; restore AC17
MOVX A,.PRIIN ; flush TTY input
CFIBF%
ERJMP .+1
CALL CRLF ; new line first
TMSG <421-Fatal system error: >
CALL ERROUT ; output last JSYS error
TMSG <, >
MOVE F,(P) ; get PC
MOVE F,-2(F) ; get instruction which lost
CALL SYMOUT ; output symbolic instruction if possible
TMSG < at PC >
POP P,F
MOVEI F,-2(F) ; point PC at actual location of the JSYS
CALL SYMOUT ; output symbolic name of the PC

; Entry point to ask for a report for non-JSYS "impossible" error

IMPERR: CALL CRLF
TMSG <421-This isn't expected to happen; please report this
421 >
JRST QUIT1 ; skip over 221 reply code in QUIT code

; Clever symbol table lookup routine. For details, read "Introduction to
; DECSYSTEM-20 Assembly Language Programming", by Ralph Gorin, published by
; Digital Press, 1981. Called with desired value in F.

SYMOUT: SETZB C,E ; no current program name or best symbol
MOVE D,.JBSYM ; symbol table pointer
HLRO A,D
SUB D,A ; -count,,ending address +1
DO.
LDB A,[POINT 4,-2(D),3] ; symbol type
IFN. A ; 0=prog name (uninteresting)
CAILE A,2 ; 1=global, 2=local
ANSKP.
MOVE A,-1(D) ; value of the symbol
CAME A,F ; exact match?
IFSKP.
MOVE E,D ; yes, select it as best symbol
EXIT.
ENDIF.
CAML A,F ; smaller than value sought?
ANSKP.
SKIPE B,E ; get best one so far if there is one
CAML A,-1(B) ; compare to previous best
MOVE E,D ; current symbol is best match so far
ENDIF.
ADD D,[2000000-2] ; add 2 in the left, sub 2 in the right
JUMPL D,TOP. ; loop unless control count is exhausted
ENDDO.
IFN. E ; if a best symbol found
MOVE A,F ; desired value
SUB A,-1(E) ; less symbol's value = offset
CAIL A,200 ; is offset small enough?
ANSKP.
MOVE A,-2(E) ; symbol name
TXZ A,<MASKB 0,3> ; clear flags
CALL SQZTYO ; print symbol name
SUB F,-1(E) ; difference between this and symbol's value
JUMPE F,R ; if no offset then done
MOVX A,"+" ; add + to the output line
PBOUT%
ENDIF.
MOVX A,.PRIOU ; and copy numeric offset to output
MOVE B,F ; value to output
MOVX C,^D8
NOUT%
ERJMP R
RET
SUBTTL Interrupt stuff

; PSI blocks

LEVTAB: LEV1PC ; priority level table
LEV2PC
LEV3PC

CHNTAB: PHASE 0 ; channel table
COFCHN:!1,,COFINT ; carrier off channel
TIMCHN:!2,,TIMINT ; timer channel
REPEAT ^D36-.,<0>
DEPHASE

; Set up PSIs

SETPSI: MOVX A,.FHSLF ; set level/channel tables
MOVE B,[LEVTAB,,CHNTAB]
SIR%
ERCAL FATAL
EIR% ; enable PSIs
ERCAL FATAL
MOVX B,<1B<TIMCHN>!1B<COFCHN>> ; on these channels
AIC%
ERCAL FATAL
MOVX A,<XWD .TICRF,COFCHN> ; arm for carrier off interrupts
ATI%
; CALLRET SETTIM

; Initialize the timer

SETTIM: MOVE A,[.FHSLF,,.TIMAL] ; remote all pending timers
TIMER%
ERCAL FATAL
MOVE A,[.FHSLF,,.TIMEL] ; tick the timer every 15 seconds
MOVX B,^D15*^D1000
MOVX C,TIMCHN
TIMER%
ERCAL FATAL
RET

; Timer interrupt

TIMINT: DMOVEM A,IN2ACS ; save ACs
MOVEM C,IN2ACS+2
AOSE TIMOUT ; has timer run out yet?
IFSKP.
MOVX A,.PRIIN ; flush TTY input
CFIBF%
ERJMP .+1
CALL CRLF ; output CRLF
TMSG <421-Autologout; idle for too long
421 >
MOVX A,<PC%USR!QUIT1> ; dismiss to quit code
MOVEM A,LEV2PC
ELSE.
CALL SETTIM ; reinitialize the timer
ENDIF.
DMOVE A,IN2ACS ; restore ACs
MOVE C,IN2ACS+2
DEBRK%

; Carrier-off interrupt

COFINT: CALL HANGUP ; hang up the connection
DEBRK% ; back out if continued
SUBTTL Other randomness

; Literals

..VAR:!VAR ; generate variables (there shouldn't be any)
IFN .-...VAR,<.FATAL Variables illegal in this program>
..LIT: XLIST ; save trees during LIT
LIT ; generate literals
LIST

END EVECL,,EVEC ; The End