robot.tcl

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