robot.tcl

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