robot.tcl

   1 #!/usr/bin/tclsh
   2 # $Id: robot.tcl,v 1.42 2003/06/11 08:49:09 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 RobotWriteRecord {outf fromurl distance} {
  30     puts $outf "<zmbot>"
  31     puts $outf "<distance>"
  32     puts $outf $distance
  33     puts $outf "</distance>"
  34     puts $outf "<fromurl>"
  35     puts $outf $fromurl
  36     puts $outf "</fromurl>"
  37     puts $outf "</zmbot>"
  38 }
  39
  40 proc RobotReadRecord {inf fromurlx distancex} {
  41     upvar $fromurlx fromurl
  42     upvar $distancex distance
  43     gets $inf
  44     gets $inf
  45     set distance [string trim [gets $inf]]
  46     # puts "got distance = $distance"
  47     gets $inf
  48     gets $inf
  49     set fromurl [string trim [gets $inf]]
  50 }
  51
  52 proc RobotFileNext {task area} {
  53     global control
  54     global idletime ns
  55     global status
  56
  57     # puts "RobotFileNext seq=$control($task,seq)"
  58     if {$control($task,seq) < 0} {
  59         return {}
  60     }
  61     if {$control($task,seq) == 0} {
  62         if {[catch {set ns($task) [glob $task/$area/*]}]} {
  63             return done
  64         }
  65     }
  66     # puts "ns=$ns($task)"
  67     set off [string length $task/$area]
  68     incr off
  69     set n [lindex $ns($task) $control($task,seq)]
  70     # puts "n=$n"
  71     if {![string length $n]} {
  72         set control($task,seq) -1
  73         flush stdout
  74         set statusfile [open $task/status w]
  75         puts $statusfile "$status($task,unvisited) $status($task,bad) $status($task,visited)"
  76         close $statusfile
  77         return wait
  78     }
  79     incr control($task,seq)
  80     if {[file isfile $n/frobots.txt]} {
  81         puts "ok returning http://[string range $n $off end]/robots.txt"
  82         return http://[string range $n $off end]/robots.txt
  83     } elseif {[file isdirectory $n]} {
  84         set sb [RobotFileNext1 $n http://[string range $n $off end]]
  85         if {[string length $sb]} {
  86             return $sb
  87         }
  88     }
  89     puts "no more work at end of RobotFileNext n=$n"
  90     puts "ns=$ns($task)"
  91     return {}
  92 }
  93
  94
  95 proc RobotFileExist {task area host path} {
  96     global debuglevel
  97
  98     if {$debuglevel > 3} {
  99         puts "RobotFileExist begin area=$area host=$host path=$path"
 100     }
 101     set lpath [split $path /]
 102     set l [llength $lpath]
 103     incr l -1
 104     set t [lindex $lpath $l]
 105     incr l -1
 106     set npath $task/$area/$host[join [lrange $lpath 0 $l] /d]/f$t
 107     if {$debuglevel > 3} {
 108         puts "RobotFileExist end npath=$npath"
 109     }
 110     return [file exists $npath]
 111 }
 112
 113 proc RobotFileUnlink {task area host path} {
 114     global status
 115     # puts "RobotFileUnlink begin"
 116     # puts "area=$area host=$host path=$path"
 117     set lpath [split $path /]
 118     set l [llength $lpath]
 119     incr l -1
 120     set t [lindex $lpath $l]
 121     incr l -1
 122     set npath $task/$area/$host[join [lrange $lpath 0 $l] /d]/f$t
 123     # puts "npath=$npath"
 124     set comp [split $npath /]
 125     if {[catch {exec rm [join $comp /]}]} return
 126
 127     set l [llength $comp]
 128     incr l -1
 129     incr l -1
 130     incr status($task,$area) -1
 131     for {set i $l} {$i > 0} {incr i -1} {
 132         set path [join [lrange $comp 0 $i] /]
 133         if {![catch {glob $path/*}]} return
 134         exec rmdir $path
 135     }
 136     # puts "RobotFileUnlink end"
 137 }
 138
 139 proc RobotFileClose {out} {
 140     if [string compare $out stdout] {
 141         close $out
 142     }
 143 }
 144
 145 proc RobotFileOpen {task area host path {mode w}} {
 146     set orgPwd [pwd]
 147     global workdir
 148     global status
 149     global debuglevel
 150
 151     # puts "RobotFileOpen task=$task path=$path"
 152
 153     if {![info exists workdir]} {
 154         return stdout
 155     }
 156     if {$debuglevel > 3} {
 157         puts "RobotFileOpen orgPwd=$orgPwd area=$area host=$host path=$path mode=$mode"
 158     }
 159     if {[string compare $orgPwd $workdir]} {
 160         puts "ooops. RobotFileOpen failed"
 161         puts "workdir = $workdir"
 162         puts "pwd = $orgPwd"
 163         exit 1
 164     }
 165
 166     set comp [split $task/$area/$host /]
 167     set len [llength $comp]
 168     incr len -1
 169
 170     # puts "1 comp=$comp"
 171
 172     for {set i 0} {$i <= $len} {incr i} {
 173         set d [lindex $comp $i]
 174         if {[string length $d] == 0} {
 175             cd /
 176         } elseif {[catch {cd $d}]} {
 177             exec mkdir $d
 178             cd ./$d
 179             if {![string compare $area unvisited] && $i == $len && $mode == "w"} {
 180                 if {[string compare $path /robots.txt]} {
 181                     set out [open frobots.txt w]
 182                     puts "creating robots.txt in $d"
 183                     close $out
 184                     incr status($task,unvisited)
 185                 }
 186             }
 187         }
 188     }
 189
 190     set comp [split $path /]
 191     set len [llength $comp]
 192     incr len -1
 193
 194     # puts "2 path=$path comp=$comp"
 195
 196     for {set i 0} {$i < $len} {incr i} {
 197         set d "d[lindex $comp $i]"
 198         if {[string length $d] > 1} {
 199             if {[catch {cd $d}]} {
 200                 exec mkdir $d
 201                 cd ./$d
 202             }
 203         }
 204     }
 205     set d [lindex $comp $len]
 206     if {[string length $d]} {
 207         set out [open f$d $mode]
 208     } else {
 209         set out [open f $mode]
 210     }
 211     if {$mode == "w"} {
 212         incr status($task,$area)
 213     }
 214     cd $orgPwd
 215     return $out
 216 }
 217
 218
 219 proc RobotStartJob {fname t} {
 220     global control
 221
 222     set f [open $fname r]
 223     set xml [read $f]
 224     puts "Reading $fname"
 225     close $f
 226     if {![regexp {<status>([^<]*)</status>} $xml x status]} {
 227         return
 228     }
 229     if {$status == "done"} {
 230         puts "already done"
 231         return
 232     }
 233     puts "status = $status"
 234     if {![task $t]} {
 235         return
 236     }
 237     htmlSwitch $xml \
 238         url {
 239             url $body
 240         } filter {
 241             set type $parm(type)
 242             set action $parm(action)
 243             if {$type == "domain"} {
 244                 $action url http://$body/*
 245             }
 246             if {$type == "url"} {
 247                 $action url $body
 248             }
 249             if {$type == "mime"} {
 250                 $action mime $body
 251             }
 252         } distance {
 253             set control($t,distance) $body
 254         } status {
 255             set control($t,filestatus) $body
 256         }
 257     if {$status == "pending"} {
 258         regsub {<status>[^<]*</status>} $xml {<status>running</status>} xml2
 259         set f [open $fname w]
 260         puts -nonewline $f $xml2
 261         close $f
 262     }
 263 }
 264
 265 proc RobotDoneJob {t} {
 266     global daemon_dir
 267
 268     if {![info exists daemon_dir]} {
 269         return
 270     }
 271
 272     set fname $t.tkl
 273
 274     set f [open $fname r]
 275     set xml [read $f]
 276     puts "Reading $fname"
 277     regexp {<status>([^<]*)</status>} $xml x status
 278     puts "------"
 279     puts "status = $status"
 280     close $f
 281
 282     regsub {<status>[^<]*</status>} $xml {<status>done</status>} xml2
 283     set f [open $fname w]
 284     puts -nonewline $f $xml2
 285     close $f
 286 }
 287
 288 proc RobotScanDir {} {
 289     global daemon_dir
 290
 291     if {![info exists daemon_dir]} {
 292         return
 293     }
 294     foreach d $daemon_dir {
 295         if {[catch {set files [glob $d/*.tkl]}]} {
 296             return
 297         }
 298         foreach fname $files {
 299             if {[file isfile $fname] && [file readable $fname]} {
 300                 set t [file rootname $fname]
 301                 RobotStartJob $fname $t
 302             }
 303         }
 304     }
 305 }
 306
 307 proc RobotRR {task} {
 308     global control robotsRunning tasks robotsMax status
 309
 310     puts "RobotRR -- running=$robotsRunning max=$robotsMax---------------"
 311     incr robotsRunning -1
 312
 313     # only one task gets through...
 314     if {[string compare [lindex $tasks 0] $task]} {
 315         return
 316     }
 317     puts "RobotRR. task = $task"
 318     while {$robotsRunning} {
 319         vwait robotsRunning
 320     }
 321     puts "Scan"
 322     if {[catch {RobotScanDir} msg]} {
 323         puts "RobotScanDir failed"
 324         puts $msg
 325     }
 326     foreach t $tasks {
 327         set statusfile [open $t/status w]
 328         puts $statusfile "$status($t,unvisited) $status($t,bad) $status($t,visited)"
 329         close $statusfile
 330         set control($t,seq) 0
 331         RobotStart $t
 332     }
 333 }
 334
 335 proc RobotDaemonSig {} {
 336     global daemon_cnt
 337
 338     incr daemon_cnt
 339 }
 340
 341 proc RobotDaemonLoop {} {
 342     global daemon_cnt tasks robotsRunning status
 343
 344     set daemon_cnt 0
 345     while 1 {
 346         puts $daemon_cnt
 347
 348         RobotScanDir
 349
 350         if {[info exists tasks]} {
 351             puts "daemon loop tasks $tasks"
 352             foreach t $tasks {
 353                 set control($t,seq) 0
 354                 RobotStart $t
 355             }
 356             while {$robotsRunning} {
 357                 vwait robotsRunning
 358             }
 359         }
 360         after 30000 RobotDaemonSig
 361         vwait daemon_cnt
 362     }
 363 }
 364
 365 proc RobotRestart {task url sock} {
 366     global URL robotsRunning
 367
 368     close $sock
 369     after cancel $URL($sock,cancel)
 370
 371     foreach v [array names URL $task,$url,*] {
 372         unset URL($v)
 373     }
 374
 375     incr robotsRunning -1
 376     RobotStart $task
 377 }
 378
 379 proc RobotStart {task} {
 380     global URL
 381     global robotsRunning robotsMax idletime status tasks
 382
 383     # puts "RobotStart $task running=$robotsRunning"
 384     while {1} {
 385         set url [RobotFileNext $task unvisited]
 386         if {[string compare $url done] == 0} {
 387             puts "In RobotStart task $task done"
 388
 389             catch {unset ntasks}
 390             foreach t $tasks {
 391                 if {[string compare $t $task]} {
 392                     lappend ntasks $t
 393                 } else {
 394                     puts "task $t done"
 395                 }
 396             }
 397             if {![info exists ntasks]} {
 398                 unset tasks
 399                 puts "all done"
 400             } else {
 401                 set tasks $ntasks
 402             }
 403             RobotDoneJob $task
 404             return
 405         }
 406         if {![string length $url]} {
 407             return
 408         }
 409         incr robotsRunning
 410         if {[string compare $url wait] == 0} {
 411             after $idletime [list RobotRR $task]
 412             return
 413         }
 414         set r [RobotGetUrl $task $url {}]
 415         if {!$r} {
 416             if {$robotsRunning >= $robotsMax} return
 417         } else {
 418             incr robotsRunning -1
 419             if {![RobotFileExist $task bad $URL($task,$url,hostport) $URL($task,$url,path)]} {
 420                 set outf [RobotFileOpen $task bad $URL($task,$url,hostport) $URL($task,$url,path)]
 421                 RobotFileClose $outf
 422             }
 423             RobotFileUnlink $task unvisited $URL($task,$url,hostport) $URL($task,$url,path)
 424         }
 425     }
 426 }
 427
 428 proc headSave {task url out} {
 429     global URL
 430
 431     if {[info exists URL($task,$url,head,last-modified)]} {
 432         puts $out "<lastmodified>$URL($task,$url,head,last-modified)</lastmodified>"
 433     }
 434     puts $out {<si>}
 435     if {[info exists URL($task,$url,head,date)]} {
 436         puts $out " <date>$URL($task,$url,head,date)</date>"
 437     }
 438     if {[info exists URL($task,$url,head,content-length)]} {
 439         puts $out " <by>$URL($task,$url,head,content-length)</by>"
 440     }
 441     if {[info exists URL($task,$url,head,server)]} {
 442         puts $out " <format>$URL($task,$url,head,server)</format>"
 443     }
 444     puts $out {</si>}
 445     puts $out {<publisher>}
 446     puts $out " <identifier>$url</identifier>"
 447     if {[info exists URL($task,$url,head,content-type)]} {
 448         puts $out " <type>$URL($task,$url,head,content-type)</type>"
 449     }
 450     puts $out {</publisher>}
 451 }
 452
 453 proc RobotHref {task url hrefx hostx pathx} {
 454     global URL control debuglevel
 455     upvar $hrefx href
 456     upvar $hostx host
 457     upvar $pathx path
 458
 459     if {$debuglevel > 1} {
 460         puts "Ref input url = $url href=$href"
 461     }
 462
 463     if {[string first { } $href] >= 0} {
 464         return 0
 465     }
 466     if {[string length $href] > 256} {
 467         return 0
 468     }
 469
 470 #   Skip pages that have ? in them
 471 #    if {[string first {?} $url] >= 0 && [string first {?} $href] >= 0} {
 472 #       return 0
 473 #    }
 474     # get method (if any)
 475     if {![regexp {^([^/:]+):(.*)} $href x method hpath]} {
 476         set hpath $href
 477         set method http
 478     } else {
 479         if {[string compare $method http]} {
 480             return 0
 481         }
 482     }
 483     # get host (if any)
 484     if {[regexp {^//([^/]+)([^\#]*)} $hpath x host surl]} {
 485         if {![string length $surl]} {
 486             set surl /
 487         }
 488         if {[info exist control($task,domains)]} {
 489             set ok 0
 490             foreach domain $control($task,domains) {
 491                 if {[string match $domain $host]} {
 492                     set ok 1
 493                     break
 494                 }
 495             }
 496             if {!$ok} {
 497                 return 0
 498             }
 499         }
 500     } else {
 501         regexp {^([^\#]*)} $hpath x surl
 502         set host $URL($task,$url,hostport)
 503     }
 504     if {![string length $surl]} {
 505         return 0
 506     }
 507     if {[string first / $surl]} {
 508         # relative path
 509         set curpath $URL($task,$url,path)
 510         if {[info exists URL($task,$url,bpath)]} {
 511             set curpath $URL($task,$url,bpath)
 512         }
 513         regexp {^([^\#?]*)} $curpath x dpart
 514         set l [string last / $dpart]
 515         if {[expr $l >= 0]} {
 516             set surl [string range $dpart 0 $l]$surl
 517         } else {
 518             set surl $dpart/$surl
 519         }
 520     }
 521     set surllist [split $surl /]
 522     catch {unset path}
 523     set pathl 0
 524     foreach c $surllist {
 525         switch -- $c {
 526             .. {
 527                 if {$pathl > 1} {
 528                     incr pathl -2
 529                     set path [lrange $path 0 $pathl]
 530                     incr pathl
 531                 }
 532             }
 533             . {
 534
 535             }
 536             default {
 537                 incr pathl
 538                 lappend path $c
 539             }
 540         }
 541     }
 542     if {$debuglevel > 4} {
 543         puts "pathl=$pathl output path=$path"
 544     }
 545     set path [join $path /]
 546     if {![string length $path]} {
 547         set path /
 548     }
 549     regsub -all {~} $path {%7E} path
 550     set href "$method://$host$path"
 551
 552     if {$debuglevel > 1} {
 553         puts "Ref result = $href"
 554     }
 555     return [checkrule $task url $href]
 556 }
 557
 558 proc RobotError {task url code} {
 559     global URL
 560
 561     puts "Bad URL $url (code $code)"
 562     set fromurl {}
 563     set distance -1
 564     if {[RobotFileExist $task unvisited $URL($task,$url,hostport) $URL($task,$url,path)]} {
 565         set inf [RobotFileOpen $task unvisited $URL($task,$url,hostport) $URL($task,$url,path) r]
 566         RobotReadRecord $inf fromurl distance
 567         RobotFileClose $inf
 568     }
 569     RobotFileUnlink $task unvisited $URL($task,$url,hostport) $URL($task,$url,path)
 570     if {![RobotFileExist $task bad $URL($task,$url,hostport) $URL($task,$url,path)]} {
 571         set outf [RobotFileOpen $task bad $URL($task,$url,hostport) $URL($task,$url,path)]
 572         RobotWriteRecord $outf $fromurl $distance
 573         RobotFileClose $outf
 574     }
 575 }
 576
 577 proc RobotRedirect {task url tourl code} {
 578     global URL
 579
 580     puts "Redirecting from $url to $tourl"
 581
 582     set distance {}
 583     set fromurl {}
 584     if {[RobotFileExist $task unvisited $URL($task,$url,hostport) $URL($task,$url,path)]} {
 585         set inf [RobotFileOpen $task unvisited $URL($task,$url,hostport) $URL($task,$url,path) r]
 586         RobotReadRecord $inf fromurl distance
 587         RobotFileClose $inf
 588     }
 589     if {![RobotFileExist $task bad $URL($task,$url,hostport) $URL($task,$url,path)]} {
 590         set outf [RobotFileOpen $task bad $URL($task,$url,hostport) $URL($task,$url,path)]
 591         RobotWriteRecord $outf $fromurl $distance
 592         RobotFileClose $outf
 593     }
 594     if {[RobotHref $task $url tourl host path]} {
 595         if {![RobotFileExist $task visited $host $path]} {
 596             if {![RobotFileExist $task unvisited $host $path]} {
 597                 set outf [RobotFileOpen $task unvisited $host $path]
 598                 RobotWriteRecord $outf $fromurl $distance
 599                 RobotFileClose $outf
 600             }
 601         } else {
 602             set olddistance {}
 603             set inf [RobotFileOpen $task visited $host $path r]
 604             RobotReadRecord $inf oldurl olddistance
 605             RobotFileClose $inf
 606             if {[string length $olddistance] == 0} {
 607                 set olddistance 1000
 608             }
 609             if {[string length $distance] == 0} {
 610                 set distance 1000
 611             }
 612             puts "distance=$distance olddistance=$olddistance"
 613             if {[expr $distance < $olddistance]} {
 614                 set outf [RobotFileOpen $task unvisited $host $path]
 615                 RobotWriteRecord $outf $tourl $distance
 616                 RobotFileClose $outf
 617             }
 618         }
 619     }
 620     if {[catch {RobotFileUnlink $task unvisited $URL($task,$url,hostport) $URL($task,$url,path)}]} {
 621         puts "unlink failed"
 622         exit 1
 623     }
 624 }
 625
 626 proc link {task url out href body distance} {
 627     global URL control
 628     if {[expr $distance > $control($task,distance)]} return
 629
 630     if {![RobotHref $task $url href host path]} return
 631
 632     puts $out "<cr>"
 633     puts $out "<identifier>$href</identifier>"
 634     puts $out "<description>$body</description>"
 635     puts $out "</cr>"
 636
 637     if {![RobotFileExist $task visited $host $path]} {
 638         set olddistance 1000
 639         if {![RobotFileExist $task bad $host $path]} {
 640             if {[RobotFileExist $task unvisited $host $path]} {
 641                 set inf [RobotFileOpen $task unvisited $host $path r]
 642                 RobotReadRecord $inf oldurl olddistance
 643                 RobotFileClose $inf
 644             }
 645         } else {
 646             set olddistance 0
 647         }
 648         if {[string length $olddistance] == 0} {
 649             set olddistance 1000
 650         }
 651         if {[expr $distance < $olddistance]} {
 652             set outf [RobotFileOpen $task unvisited $host $path]
 653             RobotWriteRecord $outf $url $distance
 654             RobotFileClose $outf
 655         }
 656     } elseif {[string compare $href $url]} {
 657         set inf [RobotFileOpen $task visited $host $path r]
 658         RobotReadRecord $inf xurl olddistance
 659         close $inf
 660         if {[string length $olddistance] == 0} {
 661             set olddistance 1000
 662         }
 663         if {[expr $distance < $olddistance]} {
 664             puts "OK remarking url=$url href=$href"
 665             puts "olddistance = $olddistance"
 666             puts "newdistance = $distance"
 667             set outf [RobotFileOpen $task unvisited $host $path]
 668             RobotWriteRecord $outf $url $distance
 669             RobotFileClose $outf
 670         }
 671     }
 672 }
 673
 674 proc RobotTextHtml {task url out} {
 675     global URL control
 676
 677     # set title so we can emit it for the body
 678     set title {}
 679     # if true, nothing will be indexed
 680     set noindex 0
 681     # if true, nothing will be followed
 682     set nofollow 0
 683
 684     set distance 0
 685     set fdistance 0
 686     if {$control($task,distance) < 1000 && [info exists URL($task,$url,dist)]} {
 687         set fdistance $URL($task,$url,dist)
 688         set distance [expr $fdistance + 1]
 689     }
 690     htmlSwitch $URL($task,$url,buf) \
 691         title {
 692             set title $body
 693         } -nonest meta {
 694             # collect metadata and save NAME= CONTENT=..
 695             set metaname {}
 696             set metacontent {}
 697             puts -nonewline $out "<meta"
 698             set al [array names parm]
 699             foreach a $al {
 700                 set al [string tolower $a]
 701                 puts -nonewline $out " $al"
 702                 puts -nonewline $out {="}
 703                 puts -nonewline $out $parm($a)
 704                 puts -nonewline $out {"}
 705                 switch -- $al {
 706                     "name" {
 707                         set metaname [string tolower $parm($a)]
 708                     }
 709                     "content" {
 710                         set metacontent $parm($a)
 711                     }
 712                 }
 713                 unset parm($al)
 714             }
 715             puts $out "></meta>"
 716             # go through robots directives (af any)
 717             if {![string compare $metaname robots]} {
 718                 set direcs [split [string tolower $metacontent] ,]
 719                 if {[lsearch $direcs noindex] >= 0} {
 720                     set noindex 1
 721                 }
 722                 if {[lsearch $direcs nofollow] >= 0} {
 723                     set nofollow 1
 724                 }
 725             }
 726         } body {
 727             # don't print title of document content if noindex is used
 728             if {!$noindex} {
 729                 puts $out "<title>$title</title>"
 730                 regsub -all {<!--[^-]*-->} $body { } abody
 731                 regsub -all -nocase {<script[^<]*</script>} $abody {} bbody
 732                 regsub -all {<[^\>]+>} $bbody {} nbody
 733                 puts $out "<documentcontent>"
 734                 puts $out $nbody
 735                 puts $out "</documentcontent>"
 736             }
 737         } -nonest base {
 738             # <base href=.. >
 739             if {![info exists parm(href)]} {
 740                 continue
 741             }
 742             set href [string trim $parm(href)]
 743             if {![RobotHref $task $url href host path]} continue
 744             set URL($task,$url,bpath) $path
 745         } a {
 746             # <a href="...."> .. </a>
 747             # we're not using nonest - otherwise body isn't set
 748             if {$nofollow} continue
 749             if {![info exists parm(href)]} {
 750                 continue
 751             }
 752             link $task $url $out [string trim $parm(href)] $body $distance
 753         } -nonest area {
 754             if {$nofollow} continue
 755             if {![info exists parm(href)]} {
 756                 continue
 757             }
 758             link $task $url $out [string trim $parm(href)] $body $distance
 759         } -nonest frame {
 760             if {![info exists parm(src)]} {
 761                 continue
 762             }
 763             link $task $url $out [string trim $parm(src)] $body $fdistance
 764         }
 765 }
 766
 767 proc RobotsTxt {task url} {
 768     global agent URL
 769
 770     RobotsTxt0 $task URL(URL($task,$url,hostport),robots) $URL($task,$url,buf)
 771 }
 772
 773 proc RobotsTxt0 {task v buf} {
 774     global URL agent
 775     set section 0
 776     foreach l [split $buf \n] {
 777         if {[regexp {([-A-Za-z]+):[ ]*([^\# ]+)} $l match cmd arg]} {
 778             set arg [string trim $arg]
 779             puts "cmd=$cmd arg=$arg"
 780             switch -- [string tolower $cmd] {
 781                 user-agent {
 782                     if {$section} break
 783                     set pat [string tolower $arg]*
 784                     set section [string match $pat $agent]
 785                 }
 786                 disallow {
 787                     if {$section} {
 788                         puts "rule [list 0 $arg]"
 789                         lappend $v [list 0 $arg]
 790                     }
 791                 }
 792                 allow {
 793                     if {$section} {
 794                         puts "rule [list 1 $arg]"
 795                         lappend $v [list 1 $arg]
 796                     }
 797                 }
 798             }
 799         }
 800     }
 801 }
 802
 803 proc RobotTextPlain {task url out} {
 804     global URL
 805
 806     puts $out "<documentcontent>"
 807     regsub -all {<} $URL($task,$url,buf) {\&lt;} content
 808     puts $out $content
 809     puts $out "</documentcontent>"
 810
 811     if {![string compare $URL($task,$url,path) /robots.txt]} {
 812         RobotsTxt $task $url
 813     }
 814 }
 815
 816 proc RobotWriteMetadata {task url out} {
 817     global URL
 818
 819     puts $out "<zmbot>"
 820
 821     set distance 1000
 822     if {[RobotFileExist $task unvisited $URL($task,$url,hostport) $URL($task,$url,path)]} {
 823         set inf [RobotFileOpen $task unvisited $URL($task,$url,hostport) $URL($task,$url,path) r]
 824         RobotReadRecord $inf fromurl distance
 825         RobotFileClose $inf
 826     }
 827     set URL($task,$url,dist) $distance
 828     puts $out "<distance>"
 829     puts $out "  $distance"
 830     puts $out "</distance>"
 831     headSave $task $url $out
 832     puts "Parsing $url distance=$distance"
 833     switch $URL($task,$url,head,content-type) {
 834         text/html {
 835             if {[string length $distance]} {
 836                 RobotTextHtml $task $url $out
 837             }
 838         }
 839         text/plain {
 840             RobotTextPlain $task $url $out
 841         }
 842     }
 843     puts $out "</zmbot>"
 844 }
 845
 846 proc Robot200 {task url} {
 847     global URL
 848
 849     set out [RobotFileOpen $task raw $URL($task,$url,hostport) $URL($task,$url,path)]
 850     puts -nonewline $out $URL($task,$url,buf)
 851     RobotFileClose $out
 852
 853     set out [RobotFileOpen $task visited $URL($task,$url,hostport) $URL($task,$url,path)]
 854     RobotWriteMetadata $task $url $out
 855     RobotFileClose $out
 856
 857     RobotFileUnlink $task unvisited $URL($task,$url,hostport) $URL($task,$url,path)
 858 }
 859
 860 proc RobotReadContent {task url sock binary} {
 861     global URL
 862
 863     set buffer [read $sock 16384]
 864     set readCount [string length $buffer]
 865
 866     if {$readCount <= 0} {
 867         Robot200 $task $url
 868         RobotRestart $task $url $sock
 869     } elseif {!$binary && [string first \0 $buffer] >= 0} {
 870         Robot200 $task $url
 871         RobotRestart $task $url $sock
 872     } else {
 873         # puts "Got $readCount bytes"
 874         set URL($task,$url,buf) $URL($task,$url,buf)$buffer
 875     }
 876 }
 877
 878 proc RobotReadHeader {task url sock} {
 879     global URL debuglevel
 880
 881     if {$debuglevel > 1} {
 882         puts "HTTP head $url"
 883     }
 884     if {[catch {set buffer [read $sock 2148]}]} {
 885         RobotError $task $url 404
 886         RobotRestart $task $url $sock
 887         return
 888     }
 889     set readCount [string length $buffer]
 890
 891     if {$readCount <= 0} {
 892         RobotError $task $url 404
 893         RobotRestart $task $url $sock
 894     } else {
 895         # puts "Got $readCount bytes"
 896         set URL($task,$url,buf) $URL($task,$url,buf)$buffer
 897
 898         set n [string first \r\n\r\n $URL($task,$url,buf)]
 899         if {$n > 1} {
 900             set code 0
 901             set version {}
 902             set headbuf [string range $URL($task,$url,buf) 0 $n]
 903             incr n 4
 904             set URL($task,$url,buf) [string range $URL($task,$url,buf) $n end]
 905
 906             regexp {^HTTP/([0-9.]+)[ ]+([0-9]+)} $headbuf x version code
 907             set lines [split $headbuf \n]
 908             foreach line $lines {
 909                 if {[regexp {^([^:]+):[ ]+([^;]*)} $line x name value]} {
 910                     set URL($task,$url,head,[string tolower $name]) [string trim $value]
 911                 }
 912             }
 913             puts "HTTP CODE $code"
 914             set URL($task,$url,state) skip
 915             switch $code {
 916                 301 {
 917                     RobotRedirect $task $url $URL($task,$url,head,location) 301
 918                     RobotRestart $task $url $sock
 919                 }
 920                 302 {
 921                     RobotRedirect $task $url $URL($task,$url,head,location) 302
 922                     RobotRestart $task $url $sock
 923                 }
 924                 200 {
 925                     if {![info exists URL($task,$url,head,content-type)]} {
 926                         set URL($task,$url,head,content-type) {}
 927                     }
 928                     set binary 1
 929                     switch -glob -- $URL($task,$url,head,content-type) {
 930                         text/* {
 931                             set binary 0
 932                         }
 933                     }
 934                     if {![regexp {/robots.txt$} $url]} {
 935                         if {![checkrule $task mime $URL($task,$url,head,content-type)]} {
 936                             RobotError $task $url mimedeny
 937                             RobotRestart $task $url $sock
 938                             return
 939                         }
 940                     }
 941                     fileevent $sock readable [list RobotReadContent $task $url $sock $binary]
 942                 }
 943                 default {
 944                     RobotError $task $url $code
 945                     RobotRestart $task $url $sock
 946                 }
 947             }
 948         }
 949     }
 950 }
 951
 952 proc RobotSockCancel {task url sock} {
 953
 954     puts "RobotSockCancel sock=$sock url=$url"
 955     RobotError $task $url 401
 956     RobotRestart $task $url $sock
 957 }
 958
 959 proc RobotConnect {task url sock} {
 960     global URL agent acceptLanguage
 961
 962     fconfigure $sock -translation {lf crlf} -blocking 0
 963     fileevent $sock readable [list RobotReadHeader $task $url $sock]
 964     puts $sock "GET $URL($task,$url,path) HTTP/1.0"
 965     puts $sock "Host: $URL($task,$url,host)"
 966     puts $sock "User-Agent: $agent"
 967     if {[string length $acceptLanguage]} {
 968         puts $sock "Accept-Language: $acceptLanguage"
 969     }
 970     puts $sock ""
 971     set URL($sock,cancel) [after 30000 [list RobotSockCancel $task $url $sock]]
 972     if {[catch {flush $sock}]} {
 973         RobotError $task $url 404
 974         RobotRestart $task $url $sock
 975     }
 976 }
 977
 978 proc RobotNop {} {
 979
 980 }
 981
 982 proc RobotGetUrl {task url phost} {
 983     global URL robotsRunning
 984     flush stdout
 985     puts "Retrieve running=$robotsRunning url=$url task=$task"
 986     if {![regexp {([^:]+)://([^/]+)(.*)} $url x method hostport path]} {
 987         return -1
 988     }
 989     if {![regexp {([^:]+):([0-9]+)} $hostport x host port]} {
 990         set port 80
 991         set host $hostport
 992     }
 993     set URL($task,$url,method) $method
 994     set URL($task,$url,host) $host
 995     set URL($task,$url,hostport) $hostport
 996     set URL($task,$url,path) $path
 997     set URL($task,$url,state) head
 998     set URL($task,$url,buf) {}
 999
1000     if {[string compare $path /robots.txt]} {
1001         set ok 1
1002         if {![info exists URL($hostport,robots)]} {
1003             puts "READING robots.txt for host $hostport"
1004             if {[RobotFileExist $task visited $hostport /robots.txt]} {
1005                 set inf [RobotFileOpen $task visited $hostport /robots.txt r]
1006                 set buf [read $inf 32768]
1007                 close $inf
1008             } else {
1009                 set buf "User-agent: *\nAllow: /\n"
1010             }
1011             RobotsTxt0 $task URL($hostport,robots) $buf
1012         }
1013         if {[info exists URL($hostport,robots)]} {
1014             foreach l $URL($hostport,robots) {
1015                 if {[string first [lindex $l 1] $path] == 0} {
1016                     set ok [lindex $l 0]
1017                     break
1018                 }
1019             }
1020         }
1021         if {!$ok} {
1022             puts "skipped due to robots.txt"
1023             return -1
1024         }
1025     }
1026     if [catch {set sock [socket -async $host $port]}] {
1027         return -1
1028     }
1029     RobotConnect $task $url $sock
1030
1031     return 0
1032 }
1033
1034 if {![llength [info commands htmlSwitch]]} {
1035     set e [info sharedlibextension]
1036     if {[catch {load ./tclrobot$e}]} {
1037         load tclrobot$e
1038     }
1039 }
1040
1041 set agent "zmbot/0.2"
1042 if {![catch {set os [exec uname -s -r]}]} {
1043     set agent "$agent ($os)"
1044 }
1045
1046 puts "agent: $agent"
1047
1048 proc bgerror {m} {
1049     global errorInfo
1050     puts "BGERROR $m"
1051     puts $errorInfo
1052 }
1053
1054 set robotsRunning 0
1055 set workdir [pwd]
1056 set idletime 30000
1057 set acceptLanguage {}
1058 set debuglevel 0
1059
1060 # Rules: allow, deny, url
1061
1062 proc checkrule {task type this} {
1063     global control
1064     global debuglevel
1065
1066     set default_ret 1
1067
1068     if {$debuglevel > 3} {
1069         puts "CHECKRULE $type $this"
1070     }
1071     if {[info exist control($task,alrules)]} {
1072         foreach l $control($task,alrules) {
1073             if {$debuglevel > 3} {
1074                 puts "consider $l"
1075             }
1076             # consider type
1077             if {[lindex $l 1] != $type} continue
1078             # consider mask (! negates)
1079             set masks [lindex $l 2]
1080             set ok 0
1081             set default_ret 0
1082             foreach mask $masks {
1083                 if {$debuglevel > 4} {
1084                     puts "consider single mask $mask"
1085                 }
1086                 if {[string index $mask 0] == "!"} {
1087                     set mask [string range $mask 1 end]
1088                     if {[string match $mask $this]}  continue
1089                 } else {
1090                     if {![string match $mask $this]} continue
1091                 }
1092                 set ok 1
1093             }
1094             if {$debuglevel > 4} {
1095                 puts "ok = $ok"
1096             }
1097             if {!$ok} continue
1098             # OK, we have a match
1099             if {[lindex $l 0] == "allow"} {
1100                 if {$debuglevel > 3} {
1101                     puts "CHECKRULE MATCH OK"
1102                 }
1103                 return 1
1104             } else {
1105                 if {$debuglevel > 3} {
1106                     puts "CHECKFULE MATCH FAIL"
1107                 }
1108                 return 0
1109             }
1110         }
1111     }
1112     if {$debuglevel > 3} {
1113         puts "CHECKRULE MATCH DEFAULT $default_ret"
1114     }
1115     return $default_ret
1116 }
1117
1118
1119 proc url {href} {
1120     global debuglevel task
1121
1122     if {[RobotHref $task http://www.indexdata.dk/ href host path]} {
1123         if {![RobotFileExist $task visited $host $path]} {
1124             set outf [RobotFileOpen $task unvisited $host $path]
1125             RobotWriteRecord $outf href 0
1126             RobotFileClose $outf
1127         }
1128     }
1129 }
1130
1131 proc deny {type stuff} {
1132     global control task
1133
1134     lappend control($task,alrules) [list deny $type $stuff]
1135 }
1136
1137 proc allow {type stuff} {
1138     global control task
1139
1140     lappend control($task,alrules) [list allow $type $stuff]
1141 }
1142
1143 proc debug {level} {
1144     global debuglevel
1145
1146     set debuglevel $level
1147 }
1148
1149 proc task {t} {
1150     global tasks task status control
1151
1152     set task $t
1153
1154     if {[info exists tasks]} {
1155         if {[lsearch -exact $tasks $t] >= 0} {
1156             return 0
1157         }
1158     }
1159
1160     lappend tasks $t
1161     set status($t,unvisited) 0
1162     set status($t,visited) 0
1163     set status($t,bad) 0
1164     set status($t,raw) 0
1165     set status($t,active) 1
1166     set control($t,seq) 0
1167     set control($t,distance) 10
1168     return 1
1169 }
1170
1171 # Little utility that ensures that at least one task is present (main).
1172 proc chktask {} {
1173     global tasks
1174     if {![info exist tasks]} {
1175         task main
1176     }
1177 }
1178
1179
1180 # Parse options
1181
1182 set i 0
1183 set l [llength $argv]
1184
1185 if {$l < 2} {
1186     puts {tclrobot: usage:}
1187     puts {tclrobot [-j jobs] [-i idle] [-c count] [-d domain] [-D dir] [-r rules] [url ..]}
1188     puts " Example: -c 3 -d '*.dk' http://www.indexdata.dk/"
1189
1190     exit 1
1191 }
1192
1193
1194 while  {$i < $l} {
1195     set arg [lindex $argv $i]
1196     switch -glob -- $arg {
1197         -t* {
1198             set t [string range $arg 2 end]
1199             if {![string length $t]} {
1200                 set t [lindex $argv [incr i]]
1201             }
1202             task $t
1203         }
1204         -D* {
1205             set dir [string range $arg 2 end]
1206             if {![string length $dir]} {
1207                 set dir [lindex $argv [incr i]]
1208             }
1209             lappend daemon_dir $dir
1210         }
1211         -j* {
1212             set robotsMax [string range $arg 2 end]
1213             if {![string length $robotsMax]} {
1214                 set robotsMax [lindex $argv [incr i]]
1215             }
1216         }
1217         -c* {
1218             chktask
1219             set control($task,distance) [string range $arg 2 end]
1220             if {![string length $control($task,distance)]} {
1221                 set control($task,distance) [lindex $argv [incr i]]
1222             }
1223         }
1224         -d* {
1225             chktask
1226             set dom [string range $arg 2 end]
1227             if {![string length $dom]} {
1228                 set dom [lindex $argv [incr i]]
1229             }
1230             lappend control($task,domains) $dom
1231         }
1232         -i* {
1233             set idletime [string range $arg 2 end]
1234             if {![string length $idletime]} {
1235                 set idletime [lindex $argv [incr i]]
1236             }
1237         }
1238         -l* {
1239             chktask
1240             set acceptLanguage [string range $arg 2 end]
1241             if {![string length $acceptLanguage]} {
1242                 set acceptLanguage [lindex $argv [incr i]]
1243             }
1244         }
1245         -r* {
1246             chktask
1247             set rfile [string range $arg 2 end]
1248             if {![string length $rfile]} {
1249                 set rfile [lindex $argv [incr i]]
1250             }
1251             catch {unset maxdistance}
1252             source $rfile
1253             if {[info exists maxdistance]} {
1254                 set control($task,distance) $maxdistance
1255             }
1256         }
1257         default {
1258             chktask
1259             set href $arg
1260             if {[RobotHref $task http://www.indexdata.dk/ href host path]} {
1261                 if {![RobotFileExist $task visited $host $path]} {
1262                     set outf [RobotFileOpen $task unvisited $host $path]
1263                     RobotWriteRecord $outf href 0
1264                     RobotFileClose $outf
1265                 }
1266             }
1267         }
1268     }
1269     incr i
1270 }
1271
1272 if {![info exist robotsMax]} {
1273     set robotsMax 5
1274 }
1275
1276 if {[info exist daemon_dir]} {
1277     RobotDaemonLoop
1278 } else {
1279     foreach t $tasks {
1280         puts "task $t"
1281         puts "max distance=$control($t,distance)"
1282         if {[info exists control($t,domains)]} {
1283             puts "domains=$control($t,domains)"
1284         }
1285     }
1286     puts "max jobs=$robotsMax"
1287
1288     foreach t $tasks {
1289         RobotStart $t
1290     }
1291
1292     while {$robotsRunning} {
1293         vwait robotsRunning
1294     }
1295
1296     if {[info exists tasks]} {
1297         foreach t $tasks {
1298             set statusfile [open $t/status w]
1299             puts $statusfile "$status($t,unvisited) $status($t,bad) $status($t,visited)"
1300             close $statusfile
1301         }
1302     }
1303 }
1304