robot.tcl

   1 #!/usr/bin/tclsh
   2 # $Id: robot.tcl,v 1.8 2000/12/10 22:27:48 adam Exp $
   3 #
   4 proc RobotFileNext1 {area} {
   5     if {[catch {set ns [glob ${area}/*]}]} {
   6         return {}
   7     }
   8     set off [string first / $area]
   9     incr off
  10
  11     foreach n $ns {
  12         if {[file isfile $n]} {
  13             if {[string first :.html $n] > 0} {
  14                 return http://[string range $area/ $off end]
  15             }
  16             return http://[string range $n $off end]
  17         }
  18     }
  19     foreach n $ns {
  20         if {[file isdirectory $n]} {
  21             set sb [RobotFileNext1 $n]
  22             if {[string length $sb]} {
  23                 return $sb
  24             }
  25         }
  26     }
  27     return {}
  28 }
  29
  30 proc RobotFileWait {} {
  31     global robotSeq
  32     set robotSeq 0
  33 }
  34
  35 proc RobotFileNext {area} {
  36     global robotSeq
  37     if {[catch {set ns [glob ${area}/*]}]} {
  38         return {}
  39     }
  40     set off [string length $area]
  41     incr off
  42
  43     set n [lindex $ns $robotSeq]
  44     if {![string length $n]} {
  45         puts "------------ N E X T  R O U N D --------"
  46         set robotSeq -1
  47         after 30000 RobotFileWait
  48         vwait robotSeq
  49
  50         set n [lindex $ns $robotSeq]
  51         if {![string length $n]} {
  52             return {}
  53         }
  54     }
  55     incr robotSeq
  56     if {[file isfile $n/robots.txt]} {
  57         puts "ok returning http://[string range $n $off end]/robots.txt"
  58         return http://[string range $n $off end]/robots.txt
  59     } elseif {[file isdirectory $n]} {
  60         set sb [RobotFileNext1 $n]
  61         if {[string length $sb]} {
  62             return $sb
  63         }
  64     }
  65     return {}
  66 }
  67
  68
  69 proc RobotFileExist {area host path} {
  70     set comp [split $area/$host$path /]
  71     set l [llength $comp]
  72     incr l -1
  73     if {![string length [lindex $comp $l]]} {
  74         set comp [split $area/$host$path:.html /]
  75     } elseif {[file exists [join $comp /]]} {
  76         return 1
  77     } else {
  78         set comp [split $area/$host$path/:.html /]
  79     }
  80     return [file exists [join $comp /]]
  81 }
  82
  83 proc RobotFileUnlink {area host path} {
  84     set comp [split $area/$host$path /]
  85     set l [llength $comp]
  86     incr l -1
  87     if {![string length [lindex $comp $l]]} {
  88         set comp [split $area/$host$path:.html /]
  89     }
  90     if {[catch {exec rm [join $comp /]}]} return
  91     incr l -1
  92     for {set i $l} {$i > 0} {incr i -1} {
  93         set path [join [lrange $comp 0 $i] /]
  94         if {![catch {glob $path/*}]} return
  95         exec rmdir ./$path
  96     }
  97 }
  98
  99 proc RobotFileClose {out} {
 100     if [string compare $out stdout] {
 101         close $out
 102     }
 103 }
 104
 105 proc RobotFileOpen {area host path {mode w}} {
 106     set orgPwd [pwd]
 107     global workdir
 108
 109     if {![info exists workdir]} {
 110         return stdout
 111     }
 112     puts "RobotFileOpen orgPwd=$orgPwd area=$area host=$host path=$path mode=$mode"
 113     if {[string compare $orgPwd $workdir]} {
 114         puts "ooops. RobotFileOpen failed"
 115         puts "workdir = $workdir"
 116         puts "pwd = $orgPwd"
 117         exit 1
 118     }
 119     set comp [split $area/$host$path /]
 120     set len [llength $comp]
 121     incr len -1
 122     for {set i 0} {$i < $len} {incr i} {
 123         set d [lindex $comp $i]
 124         if {[catch {cd ./$d}]} {
 125             exec mkdir $d
 126             cd ./$d
 127             if {![string compare $area unvisited] && $i == 1 && $mode == "w"} {
 128                 set out [open robots.txt w]
 129                 puts "creating robots.txt in $d"
 130                 close $out
 131             }
 132         }
 133     }
 134     set d [lindex $comp $len]
 135     if {[string length $d]} {
 136         if {[file isdirectory $d]} {
 137             set out [open $d/:.html $mode]
 138         } else {
 139             set out [open $d $mode]
 140         }
 141     } else {
 142         set out [open :.html $mode]
 143     }
 144     cd $orgPwd
 145     #puts "RobotFileStop"
 146     return $out
 147 }
 148
 149 proc RobotRestart {sock} {
 150     global URL
 151     global robotMoreWork
 152
 153     close $sock
 154     after cancel $URL($sock,cancel)
 155     while {1} {
 156         set url [RobotFileNext unvisited]
 157         if {![string length $url]} {
 158             break
 159         }
 160         set r [RobotGetUrl $url {}]
 161         if {!$r} {
 162             return
 163         } else {
 164             RobotFileUnlink unvisited $URL($url,host) $URL($url,path)
 165         }
 166     }
 167     incr robotMoreWork -1
 168 }
 169
 170 proc headSave {url out} {
 171     global URL
 172
 173     puts $out {<zmbot>}
 174     if {[info exists URL($url,head,last-modified)]} {
 175         puts $out "<lastmodified>$URL($url,head,last-modified)</lastmodified>"
 176     }
 177     puts $out {<si>}
 178     if {[info exists URL($url,head,date)]} {
 179         puts $out " <date>$URL($url,head,date)</date>"
 180     }
 181     if {[info exists URL($url,head,content-length)]} {
 182         puts $out " <by>$URL($url,head,content-length)</by>"
 183     }
 184     if {[info exists URL($url,head,server)]} {
 185         puts $out " <format>$URL($url,head,server)</format>"
 186     }
 187     puts $out {</si>}
 188     puts $out {<publisher>}
 189     puts $out " <identifier>$url</identifier>"
 190     if {[info exists URL($url,head,content-type)]} {
 191         puts $out " <type>$URL($url,head,content-type)</type>"
 192     }
 193     puts $out {</publisher>}
 194 }
 195
 196 proc RobotHref {url hrefx hostx pathx} {
 197     global URL domains
 198     upvar $hrefx href
 199     upvar $hostx host
 200     upvar $pathx path
 201
 202     puts "Ref url = $url href=$href"
 203     # get method (if any)
 204     if {![regexp {^([^/:]+):(.*)} $href x method hpath]} {
 205         set hpath $href
 206         set method http
 207     } else {
 208         if {[string compare $method http]} {
 209             return 0
 210         }
 211     }
 212     # get host (if any)
 213     if {[regexp {^//([^/]+)([^\#]*)} $hpath x host surl]} {
 214         if {![string length $surl]} {
 215             set surl /
 216         }
 217         set ok 0
 218         foreach domain $domains {
 219             if {[string match $domain $host]} {
 220                 set ok 1
 221                 break
 222             }
 223         }
 224         if {!$ok} {
 225             return 0
 226         }
 227     } else {
 228         regexp {^([^\#]*)} $hpath x surl
 229         set host $URL($url,host)
 230     }
 231     if {![string length $surl]} {
 232         return 0
 233     }
 234     if {[string first / $surl]} {
 235         # relative path
 236         regexp {^([^\#?]*)} $URL($url,path) x dpart
 237         set l [string last / $dpart]
 238         if {[expr $l >= 0]} {
 239             set surl [string range $dpart 0 $l]$surl
 240         } else {
 241             set surl $dpart/$surl
 242         }
 243     }
 244     set c [split $surl /]
 245     set i [llength $c]
 246     incr i -1
 247     set path [lindex $c $i]
 248     incr i -1
 249     while {$i >= 0} {
 250         switch -- [lindex $c $i] {
 251             .. {
 252                 incr i -2
 253             }
 254             . {
 255                 incr i -1
 256             }
 257             default {
 258                 set path [lindex $c $i]/$path
 259                 incr i -1
 260             }
 261         }
 262     }
 263     regsub -all {~} $path {%7E} path
 264     set ok 1
 265     if {[info exists URL($host,robots)]} {
 266         foreach l $URL($host,robots) {
 267             if {[string first [lindex $l 1] $path] == 0} {
 268                 set ok [lindex $l 0]
 269                 break
 270             }
 271         }
 272     }
 273     set href "$method://$host$path"
 274     puts "Ref href = $href, ok=$ok"
 275     return $ok
 276 }
 277
 278 proc RobotError {url code} {
 279     global URL
 280
 281     puts "Bad URL $url, $code"
 282     set fromurl {}
 283     if {[RobotFileExist unvisited $URL($url,host) $URL($url,path)]} {
 284         set inf [RobotFileOpen unvisited $URL($url,host) $URL($url,path) r]
 285         set fromurl [gets $inf]
 286         close $inf
 287     }
 288     RobotFileUnlink unvisited $URL($url,host) $URL($url,path)
 289     if {![RobotFileExist bad $URL($url,host) $URL($url,path)]} {
 290         set outf [RobotFileOpen bad $URL($url,host) $URL($url,path)]
 291         puts $outf "URL=$url $code"
 292         puts $outf "Reference $fromurl"
 293         RobotFileClose $outf
 294     }
 295 }
 296
 297 proc RobotRedirect {url tourl code} {
 298     global URL
 299
 300     puts "Redirecting from $url to $tourl"
 301
 302     set fromurl {}
 303     catch {
 304         set inf [RobotFileOpen unvisited $URL($url,host) $URL($url,path) r]
 305         set fromurl [gets $inf]
 306         RobotFileClose $inf
 307     }
 308     RobotFileUnlink unvisited $URL($url,host) $URL($url,path)
 309     if {![RobotFileExist bad $URL($url,host) $URL($url,path)]} {
 310         set outf [RobotFileOpen bad $URL($url,host) $URL($url,path)]
 311         puts $outf "URL=$url to $tourl $code"
 312         puts $outf "Reference $fromurl"
 313         RobotFileClose $outf
 314     }
 315     if {[RobotHref $url tourl host path]} {
 316         if {![RobotFileExist unvisited $host $path]} {
 317                 puts "Mark as unvisited"
 318             set outf [RobotFileOpen unvisited $host $path]
 319             puts $outf $code
 320             RobotFileClose $outf
 321         }
 322     }
 323 }
 324
 325 proc RobotTextHtml {url out} {
 326     global URL
 327
 328     set head 0
 329     htmlSwitch $URL($url,buf) \
 330         title {
 331             if {!$head} {
 332                 headSave $url $out
 333                 set head 1
 334             }
 335             puts $out "<title>$body</title>"
 336         } -nonest meta {
 337             if {!$head} {
 338                 headSave $url $out
 339                 set head 1
 340             }
 341             puts -nonewline $out "<meta"
 342             foreach a [array names parm] {
 343                 puts -nonewline $out " $a"
 344                 puts -nonewline $out {="}
 345                 puts -nonewline $out $parm($a)
 346                 puts -nonewline $out {"}
 347             }
 348             puts $out {></meta>}
 349         } body {
 350             regsub -all -nocase {<script.*</script>} $body {} abody
 351             regsub -all {<[^\>]+>} $abody {} nbody
 352             puts $out "<documentcontent>"
 353             puts $out $nbody
 354             puts $out "</documentcontent>"
 355         } a {
 356             if {![info exists parm(href)]} {
 357                 puts "no href"
 358                 continue
 359             }
 360             if {!$head} {
 361                 headSave $url $out
 362                 set head 1
 363             }
 364             if {1} {
 365                 set href $parm(href)
 366                 if {![RobotHref $url href host path]} continue
 367
 368                 puts $out "<cr>"
 369                 puts $out "<identifier>$href</identifier>"
 370                 puts $out "<description>$body</description>"
 371                 puts $out "</cr>"
 372
 373                 if {![RobotFileExist visited $host $path]} {
 374                     if {![RobotFileExist bad $host $path]} {
 375                         if {[catch {set outf [RobotFileOpen unvisited $host $path]} msg]} {
 376                             puts "--- Error $msg"
 377                             exit 1
 378                         }
 379                         puts $outf $url
 380                         RobotFileClose $outf
 381                     }
 382                 }
 383             }
 384         }
 385     if {!$head} {
 386         headSave $url $out
 387         set head 1
 388     }
 389     puts $out "</zmbot>"
 390 }
 391
 392 proc RobotsTxt {url} {
 393     global agent URL
 394
 395     set v URL($URL($url,host),robots)
 396     set section 0
 397     foreach l [split $URL($url,buf) \n] {
 398         puts $l
 399         if {[regexp {([-A-Za-z]+):[ \t]*([^\#]+)} $l match cmd arg]} {
 400             puts "cmd=$cmd arg=$arg"
 401             switch $cmd {
 402                 User-Agent {
 403                     if {$section} break
 404                     set pat [string tolower $arg]*
 405                     set section [string match $pat $agent]
 406                 }
 407                 Disallow {
 408                     if {$section} {
 409                         puts "rule [list 0 $arg]"
 410                         lappend $v [list 0 $arg]
 411                     }
 412                 }
 413                 Allow {
 414                     if {$section} {
 415                         puts "rule [list 1 $arg]"
 416                         lappend $v [list 1 $arg]
 417                     }
 418                 }
 419             }
 420         }
 421     }
 422 }
 423
 424 proc RobotTextPlain {url out} {
 425     global URL
 426
 427     headSave $url $out
 428     puts $out "<documentcontent>"
 429     puts $out $URL($url,buf)
 430     puts $out "</documentcontent>"
 431     puts $out "</meta>"
 432
 433     if {![string compare $URL($url,path) /robots.txt]} {
 434         RobotsTxt $url
 435     }
 436 }
 437
 438 proc Robot200 {url} {
 439     global URL domains
 440
 441     puts "Parsing $url"
 442     set out [RobotFileOpen visited $URL($url,host) $URL($url,path)]
 443     switch $URL($url,head,content-type) {
 444         text/html {
 445             RobotTextHtml $url $out
 446         }
 447         text/plain {
 448             RobotTextPlain $url $out
 449         }
 450         default {
 451             headSave $url $out
 452             puts $out "</zmbot>"
 453         }
 454     }
 455     RobotFileClose $out
 456     # puts "Parsing done"
 457     RobotFileUnlink unvisited $URL($url,host) $URL($url,path)
 458 }
 459
 460 proc RobotReadContent {url sock} {
 461     global URL
 462
 463     set buffer [read $sock 16384]
 464     set readCount [string length $buffer]
 465
 466     if {$readCount <= 0} {
 467         Robot200 $url
 468         RobotRestart $sock
 469     } elseif {[string first \0 $buffer] >= 0} {
 470         Robot200 $url
 471         RobotRestart $sock
 472     } else {
 473         # puts "Got $readCount bytes"
 474         set URL($url,buf) $URL($url,buf)$buffer
 475     }
 476 }
 477
 478 proc RobotReadHeader {url sock} {
 479     global URL
 480
 481     if {[catch {set buffer [read $sock 2148]}]} {
 482         RobotError $url 404
 483         RobotRestart $sock
 484     }
 485     set readCount [string length $buffer]
 486
 487     if {$readCount <= 0} {
 488         RobotError $url 404
 489         RobotRestart $sock
 490     } else {
 491         # puts "Got $readCount bytes"
 492         set URL($url,buf) $URL($url,buf)$buffer
 493
 494         set n [string first \n\n $URL($url,buf)]
 495         if {$n > 1} {
 496             set code 0
 497             set version {}
 498             set headbuf [string range $URL($url,buf) 0 $n]
 499             incr n
 500             incr n
 501             set URL($url,buf) [string range $URL($url,buf) $n end]
 502
 503             regexp {^HTTP/([0-9.]+)[ ]+([0-9]+)} $headbuf x version code
 504             set lines [split $headbuf \n]
 505             foreach line $lines {
 506                 if {[regexp {^([^:]+):[ ]+(.*)} $line x name value]} {
 507                     set URL($url,head,[string tolower $name]) $value
 508                 }
 509             }
 510             puts "code = $code"
 511             set URL($url,state) skip
 512             switch $code {
 513                 301 {
 514                     RobotRedirect $url $URL($url,head,location) 301
 515                     RobotRestart $sock
 516                 }
 517                 302 {
 518                     RobotRedirect $url $URL($url,head,location) 302
 519                     RobotRestart $sock
 520                 }
 521                 404 {
 522                     RobotError $url 404
 523                     RobotRestart $sock
 524                 }
 525                 401 {
 526                     RobotError $url 401
 527                     RobotRestart $sock
 528                 }
 529                 200 {
 530                     if {![info exists URL($url,head,content-type)]} {
 531                         set URL($url,head,content-type) {}
 532                     }
 533                     switch $URL($url,head,content-type) {
 534                         text/html {
 535                             fileevent $sock readable [list RobotReadContent $url $sock]
 536                         }
 537                         text/plain {
 538                             fileevent $sock readable [list RobotReadContent $url $sock]
 539                         }
 540                         default {
 541                             Robot200 $url
 542                             RobotRestart $sock
 543                         }
 544                     }
 545                 }
 546                 default {
 547                     RobotError $url 404
 548                     RobotRestart $sock
 549                 }
 550             }
 551         }
 552     }
 553 }
 554
 555 proc RobotSockCancel {sock url} {
 556
 557     puts "RobotSockCancel sock=$sock url=$url"
 558     RobotError $url 401
 559     RobotRestart $sock
 560 }
 561
 562 proc RobotConnect {url sock} {
 563     global URL agent
 564
 565     fconfigure $sock -translation {auto crlf} -blocking 0
 566     fileevent $sock readable [list RobotReadHeader $url $sock]
 567     puts $sock "GET $URL($url,path) HTTP/1.0"
 568     puts $sock "Host: $URL($url,host)"
 569     puts $sock "User-Agent: $agent"
 570     puts $sock ""
 571     flush $sock
 572     set URL($sock,cancel) [after 60000 [list RobotSockCancel $sock $url]]
 573 }
 574
 575 proc RobotNop {} {
 576
 577 }
 578
 579 proc RobotGetUrl {url phost} {
 580     global URL
 581     puts "---------"
 582     puts $url
 583     if {![regexp {([^:]+)://([^/]+)([^ ]*)} $url x method hostport path]} {
 584         return -1
 585     }
 586     if {![regexp {([^:]+):([0-9]+)} $hostport x host port]} {
 587         set port 80
 588         set host $hostport
 589     }
 590     set URL($url,method) $method
 591     set URL($url,host) $host
 592     set URL($url,port) $port
 593     set URL($url,path) $path
 594     set URL($url,state) head
 595     set URL($url,buf) {}
 596     if [catch {set sock [socket -async $host $port]}] {
 597         return -1
 598     }
 599     RobotConnect $url $sock
 600
 601     return 0
 602 }
 603
 604 if {![llength [info commands htmlSwitch]]} {
 605     set e [info sharedlibextension]
 606     if {[catch {load ./tclrobot$e}]} {
 607         load tclrobot$e
 608     }
 609 }
 610
 611 set agent "zmbot/0.0"
 612 if {![catch {set os [exec uname -s -r]}]} {
 613     set agent "$agent ($os)"
 614         puts "agent: $agent"
 615 }
 616
 617 proc bgerror {m} {
 618     global errorInfo
 619     puts "BGERROR $m"
 620     puts $errorInfo
 621 }
 622
 623 set robotMoreWork 0
 624 set robotSeq 0
 625 set workdir [pwd]
 626
 627 if {[llength $argv] < 2} {
 628     puts "Tclrobot: usage <domain> <start>"
 629     puts " Example: '*.indexdata.dk' http://www.indexdata.dk/"
 630     exit 1
 631 }
 632
 633 set domains [lindex $argv 0]
 634 foreach site [lindex $argv 1] {
 635     incr robotMoreWork
 636     if [RobotGetUrl $site {}] {
 637         incr robotMoreWork -1
 638         puts "Couldn't process $site"
 639     }
 640 }
 641
 642 while {$robotMoreWork} {
 643     vwait robotMoreWork
 644 }