1# spf.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
2#
3#                         Sender Policy Framework
4#
5#    http://www.ietf.org/internet-drafts/draft-ietf-marid-protocol-00.txt
6#    http://spf.pobox.com/
7#
8# Some domains using SPF:
9#   pobox.org       - mx, a, ptr
10#   oxford.ac.uk    - include
11#   gnu.org         - ip4
12#   aol.com         - ip4, ptr
13#   sourceforge.net - mx, a
14#   altavista.com   - exists,  multiple TXT replies.
15#   oreilly.com     - mx, ptr, include
16#   motleyfool.com  - include (looping includes)
17#
18# -------------------------------------------------------------------------
19# See the file "license.terms" for information on usage and redistribution
20# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
21# -------------------------------------------------------------------------
22#
23# $Id: spf.tcl,v 1.5 2008/03/14 21:21:12 andreas_kupries Exp $
24
25package require Tcl 8.2;                # tcl minimum version
26package require dns;                    # tcllib 1.3
27package require logger;                 # tcllib 1.3
28package require ip;                     # tcllib 1.7
29package require struct::list;           # tcllib 1.7
30package require uri::urn;               # tcllib 1.3
31
32namespace eval spf {
33    variable version 1.1.1
34    variable rcsid {$Id: spf.tcl,v 1.5 2008/03/14 21:21:12 andreas_kupries Exp $}
35
36    namespace export spf
37
38    variable uid
39    if {![info exists uid]} {set uid 0}
40
41    variable log
42    if {![info exists log]} {
43        set log [logger::init spf]
44        ${log}::setlevel warn
45        proc ${log}::stdoutcmd {level text} {
46            variable service
47            puts "\[[clock format [clock seconds] -format {%H:%M:%S}]\
48                $service $level\] $text"
49        }
50    }
51}
52
53# -------------------------------------------------------------------------
54# ip     : ip address of the connecting host
55# domain : the domain to match
56# sender : full sender email address
57#
58proc ::spf::spf {ip domain sender} {
59    variable log
60
61    # 3.3: Initial processing
62    # If the sender address has no local part, set it to postmaster
63    set addr [split $sender @]
64    if {[set len [llength $addr]] == 0} {
65        return -code error -errorcode permanent "invalid sender address"
66    } elseif {$len == 1} {
67        set sender "postmaster@$sender"
68    }
69
70    # 3.4: Record lookup
71    set spf [SPF $domain]
72    if {[string equal $spf none]} {
73        return $spf
74    }
75
76    return [Spf $ip $domain $sender $spf]
77}
78
79proc ::spf::Spf {ip domain sender spf} {
80    variable log
81
82    # 3.4.1: Matching Version
83    if {![regexp {^v=spf(\d)\s+} $spf -> version]} {
84        return none
85    }
86
87    ${log}::debug "$spf"
88
89    if {$version != 1} {
90        return -code error -errorcode permanent \
91            "version mismatch: we only understand SPF 1\
92            this domain has provided version \"$version\""
93    }
94
95    set result ?
96    set seen_domains $domain
97    set explanation {denied}
98
99    set directives [lrange [split $spf { }] 1 end]
100    foreach directive $directives {
101        set prefix [string range $directive 0 0]
102        if {[string equal $prefix "+"] || [string equal $prefix "-"]
103            || [string equal $prefix "?"] || [string equal $prefix "~"]} {
104            set directive [string range $directive 1 end]
105        } else {
106            set prefix "+"
107        }
108
109        set cmd [string tolower [lindex [split $directive {:/=}] 0]]
110        set param [string range $directive [string length $cmd] end]
111
112        if {[info command ::spf::_$cmd] == {}} {
113            # 6.1 Unrecognised directives terminate processing
114            #     but unknown modifiers are ignored.
115            if {[string match "=*" $param]} {
116                continue
117            } else {
118                set result unknown
119                break
120            }
121        } else {
122            set r [catch {::spf::_$cmd $ip $domain $sender $param} res]
123            if {$r} {
124                if {$r == 2} {return $res};# deal with return -code return
125                if {[string equal $res "none"]
126                    || [string equal $res "error"]
127                    || [string equal $res "unknown"]} {
128                    return $res
129                }
130                return -code error "error in \"$cmd\": $res"
131            }
132            if {$res} { set result $prefix }
133        }
134
135        ${log}::debug "$prefix $cmd\($param) -> $result"
136        if {[string equal $result "+"]} break
137    }
138
139    return $result
140}
141
142proc ::spf::loglevel {level} {
143    variable log
144    ${log}::setlevel $level
145}
146
147# get a guaranteed unique and non-present token id.
148proc ::spf::create_token {} {
149    variable uid
150    set id [incr uid]
151    while {[info exists [set token [namespace current]::$id]]} {
152        set id [incr uid]
153    }
154    return $token
155}
156
157# -------------------------------------------------------------------------
158#
159#                      SPF MECHANISM HANDLERS
160#
161# -------------------------------------------------------------------------
162
163# 4.1:	The "all" mechanism is a test that always matches.  It is used as the
164#	rightmost mechanism in an SPF record to provide an explicit default
165#
166proc ::spf::_all {ip domain sender param} {
167    return 1
168}
169
170# 4.2:	The "include" mechanism triggers a recursive SPF query.
171#	The domain-spec is expanded as per section 8.
172proc ::spf::_include {ip domain sender param} {
173    variable log
174    upvar seen_domains Seen
175
176    if {![string equal [string range $param 0 0] ":"]} {
177        return -code error "dubious parameters for \"include\""
178    }
179    set r ?
180    set new_domain [Expand [string range $param 1 end] $ip $domain $sender]
181    if {[lsearch $Seen $new_domain] == -1} {
182        lappend Seen $new_domain
183        set spf [SPF $new_domain]
184        if {[string equal $spf none]} {
185            return $spf
186        }
187        set r [Spf $ip $new_domain $sender $spf]
188    }
189    return [string equal $r "+"]
190}
191
192# 4.4:	This mechanism matches if <ip> is one of the target's
193#	IP addresses.
194#	e.g: a:smtp.example.com a:mail.%{d} a
195#
196proc ::spf::_a {ip domain sender param} {
197    variable log
198    foreach {testdomain bits} [ip::SplitIp [string trimleft $param :]] {}
199    if {[string length $testdomain] < 1} {
200        set testdomain $domain
201    } else {
202        set testdomain [Expand $testdomain $ip $domain $sender]
203    }
204    ${log}::debug "  fetching A for $testdomain"
205    set dips [A $testdomain];           # get the IPs for the testdomain
206    foreach dip $dips {
207        ${log}::debug "  compare: ${ip}/${bits} with ${dip}/${bits}"
208        if {[ip::equal $ip/$bits $dip/$bits]} {
209            return 1
210        }
211    }
212    return 0
213}
214
215# 4.5: This mechanism matches if the <sending-host> is one of the MX hosts
216#      for a domain name.
217#
218proc ::spf::_mx {ip domain sender param} {
219    variable log
220    foreach {testdomain bits} [ip::SplitIp [string trimleft $param :]] {}
221    if {[string length $testdomain] < 1} {
222        set testdomain $domain
223    } else {
224        set testdomain [Expand $testdomain $ip $domain $sender]
225    }
226    ${log}::debug "  fetching MX for $testdomain"
227    set mxs [MX $testdomain]
228
229    foreach mx $mxs {
230        set mx [lindex $mx 1]
231        set mxips [A $mx]
232        foreach mxip $mxips {
233            ${log}::debug "  compare: ${ip}/${bits} with ${mxip}/${bits}"
234            if {[ip::equal $ip/$bits $mxip/$bits]} {
235                return 1
236            }
237        }
238    }
239    return 0
240}
241
242# 4.6: This mechanism tests if the <sending-host>'s name is within a
243#      particular domain.
244#
245proc ::spf::_ptr {ip domain sender param} {
246    variable log
247    set validnames {}
248    if {[catch { set names [PTR $ip] } msg]} {
249        ${log}::debug "  \"$ip\" $msg"
250        return 0
251    }
252    foreach name $names {
253        set addrs [A $name]
254        foreach addr $addrs {
255            if {[ip::equal $ip $addr]} {
256                lappend validnames $name
257                continue
258            }
259        }
260    }
261
262    ${log}::debug "  validnames: $validnames"
263    set testdomain [Expand [string trimleft $param :] $ip $domain $sender]
264    if {$testdomain == {}} {
265        set testdomain $domain
266    }
267    foreach name $validnames {
268        if {[string match "*$testdomain" $name]} {
269            return 1
270        }
271    }
272
273    return 0
274}
275
276# 4.7: These mechanisms test if the <sending-host> falls into a given IP
277#      network.
278#
279proc ::spf::_ip4 {ip domain sender param} {
280    variable log
281    foreach {network bits} [ip::SplitIp [string range $param 1 end]] {}
282    ${log}::debug "  compare ${ip}/${bits} to ${network}/${bits}"
283    if {[ip::equal $ip/$bits $network/$bits]} {
284        return 1
285    }
286    return 0
287}
288
289# 4.6: These mechanisms test if the <sending-host> falls into a given IP
290#      network.
291#
292proc ::spf::_ip6 {ip domain sender param} {
293    variable log
294    foreach {network bits} [ip::SplitIp [string range $param 1 end]] {}
295    ${log}::debug "  compare ${ip}/${bits} to ${network}/${bits}"
296    if {[ip::equal $ip/$bits $network/$bits]} {
297        return 1
298    }
299    return 0
300}
301
302# 4.7: This mechanism is used to construct an arbitrary host name that is
303#      used for a DNS A record query.  It allows for complicated schemes
304#      involving arbitrary parts of the mail envelope to determine what is
305#      legal.
306#
307proc ::spf::_exists {ip domain sender param} {
308    variable log
309    set testdomain [Expand [string range $param 1 end] $ip $domain $sender]
310    ${log}::debug "   checking existence of '$testdomain'"
311    if {[catch {A $testdomain}]} {
312        return 0
313    }
314    return 1
315}
316
317# 5.1: Redirected query
318#
319proc ::spf::_redirect {ip domain sender param} {
320    variable log
321    set new_domain [Expand [string range $param 1 end] $ip $domain $sender]
322    ${log}::debug ">> redirect to '$new_domain'"
323    set spf [SPF $new_domain]
324    if {![string equal $spf none]} {
325        set spf [Spf $ip $new_domain $sender $spf]
326    }
327    ${log}::debug "<< redirect returning '$spf'"
328    return -code return $spf
329}
330
331# 5.2: Explanation
332#
333proc ::spf::_exp {ip domain sender param} {
334    variable log
335    set new_domain [string range $param 1 end]
336    set exp [TXT $new_domain]
337    set exp [Expand $exp $ip $domain $sender]
338    ${log}::debug "exp expanded to \"$exp\""
339    # FIX ME: need to store this somehow.
340}
341
342# 5.3: Sender accreditation
343#
344proc ::spf::_accredit {ip domain sender param} {
345    variable log
346    set accredit [Expand [string range $param 1 end] $ip $domain $sender]
347    ${log}::debug "  accreditation '$accredit'"
348    # We are not using this at the moment.
349    return 0
350}
351
352
353# 7: Macro expansion
354#
355proc ::spf::Expand {txt ip domain sender} {
356    variable log
357    set re {%\{[[:alpha:]](?:\d+)?r?[\+\-\.,/_=]*\}}
358    set txt [string map {\[ \\\[ \] \\\]} $txt]
359    regsub -all $re $txt {[ExpandMacro & $ip $domain $sender]} cmd
360    set cmd [string map {%% % %_ \  %- %20} $cmd]
361    return [subst -novariables $cmd]
362}
363
364proc ::spf::ExpandMacro {macro ip domain sender} {
365    variable log
366    set re {%\{([[:alpha:]])(\d+)?(r)?([\+\-\.,/_=]*)\}}
367    set C {} ; set T {} ; set R {}; set D {}
368    set r [regexp $re $macro -> C T R D]
369    if {$R == {}} {set R 0} else {set R 1}
370    set res $macro
371    if {$r} {
372        set enc [string is upper $C]
373        switch -exact -- [string tolower $C] {
374            s { set res $sender }
375            l {
376                set addr [split $sender @]
377                if {[llength $addr] < 2} {
378                    set res postmaster
379                } else {
380                    set res [lindex $addr 0]
381                }
382            }
383            o {
384                set addr [split $sender @]
385                if {[llength $addr] < 2} {
386                    set res $sender
387                } else {
388                    set res [lindex $addr 1]
389                }
390            }
391            h - d { set res $domain }
392            i {
393                set res [ip::normalize $ip]
394                if {[ip::is ipv6 $res]} {
395                    # Convert 0000:0001 to 0.1
396                    set t {}
397                    binary scan [ip::Normalize $ip 6] c* octets
398                    foreach octet $octets {
399                        set hi [expr {($octet & 0xF0) >> 4}]
400                        set lo [expr {$octet & 0x0F}]
401                        lappend t [format %x $hi] [format %x $lo]
402                    }
403                    set res [join $t .]
404                }
405            }
406            v {
407                if {[ip::is ipv6 $ip]} {
408                    set res ip6
409                } else {
410                    set res "in-addr"
411                }
412            }
413            c {
414                set res [ip::normalize $ip]
415                if {[ip::is ipv6 $res]} {
416                    set res [ip::contract $res]
417                }
418            }
419            r {
420                set s [socket -server {} -myaddr [info host] 0]
421                set res [lindex [fconfigure $s -sockname] 1]
422                close $s
423            }
424            t { set res [clock seconds] }
425        }
426        if {$T != {} || $R || $D != {}} {
427            if {$D == {}} {set D .}
428            set res [split $res $D]
429            if {$R} {
430                set res [struct::list::Lreverse $res]
431            }
432            if {$T != {}} {
433                incr T -1
434                set res [join [lrange $res end-$T end] $D]
435            }
436            set res [join $res .]
437        }
438        if {$enc} {
439            # URI encode the result.
440            set res [uri::urn::quote $res]
441        }
442    }
443    return $res
444}
445
446# -------------------------------------------------------------------------
447#
448# DNS helper procedures.
449#
450# -------------------------------------------------------------------------
451
452proc ::spf::Resolve {domain type resultproc} {
453    if {[info command $resultproc] == {}} {
454        return -code error "invalid arg: \"$resultproc\" must be a command"
455    }
456    set tok [dns::resolve $domain -type $type]
457    dns::wait $tok
458    set errorcode NONE
459    if {[string equal [dns::status $tok] "ok"]} {
460        set result [$resultproc $tok]
461        set code   ok
462    } else {
463        set result    [dns::error $tok]
464        set errorcode [dns::errorcode $tok]
465        set code      error
466    }
467    dns::cleanup $tok
468    return -code $code -errorcode $errorcode $result
469}
470
471# 3.4: Record lookup
472proc ::spf::SPF {domain} {
473    set txt ""
474    if {[catch {Resolve $domain SPF ::dns::result} spf]} {
475        set code $::errorCode
476        ${log}::debug "error fetching SPF record: $r"
477        switch -exact -- $code {
478            3 { return -code return [list - "Domain Does Not Exist"] }
479            2 { return -code error -errorcode temporary $spf }
480        }
481        set txt none
482    } else {
483        foreach res $spf {
484            set ndx [lsearch $res rdata]
485            incr ndx
486            if {$ndx != 0} {
487                append txt [string range [lindex $res $ndx] 1 end]
488            }
489        }
490    }
491    return $txt
492}
493
494proc ::spf::TXT {domain} {
495    set r [Resolve $domain TXT ::dns::result]
496    set txt ""
497    foreach res $r {
498        set ndx [lsearch $res rdata]
499        incr ndx
500        if {$ndx != 0} {
501            append txt [string range [lindex $res $ndx] 1 end]
502        }
503    }
504    return $txt
505}
506
507proc ::spf::A {name} {
508    return [Resolve $name A ::dns::address]
509}
510
511
512proc ::spf::AAAA {name} {
513    return [Resolve $name AAAA ::dns::address]
514}
515
516proc ::spf::PTR {addr} {
517    return [Resolve $addr A ::dns::name]
518}
519
520proc ::spf::MX {domain} {
521    set r [Resolve $domain MX ::dns::name]
522    return [lsort -index 0 $r]
523}
524
525
526# -------------------------------------------------------------------------
527
528package provide spf $::spf::version
529
530# -------------------------------------------------------------------------
531# Local Variables:
532#   indent-tabs-mode: nil
533# End:
534