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