extra/spider/spider.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors fry html.parser html.parser.analyzer
   4 http.client kernel tools.time sets assocs sequences
   5 concurrency.combinators io threads namespaces math multiline
   6 heaps math.parser inspector urls assoc-heaps logging
   7 combinators.short-circuit continuations calendar prettyprint ;
   8 IN: spider
   9
  10 TUPLE: spider base count max-count sleep max-depth initial-links
  11 filters spidered todo nonmatching quiet ;
  12 ! secure? agent page-timeout data-timeout overall-timeout
  13
  14 TUPLE: spider-result url depth headers fetch-time parsed-html
  15 links processing-time timestamp ;
  16
  17 : <spider> ( base -- spider )
  18     >url
  19     spider new
  20         over >>base
  21         swap 0 <unique-min-heap> [ heap-push ] keep >>todo
  22         <unique-min-heap> >>nonmatching
  23         0 >>max-depth
  24         0 >>count
  25         1/0. >>max-count
  26         H{ } clone >>spidered ;
  27
  28 <PRIVATE
  29
  30 : relative-url? ( url -- ? ) protocol>> not ;
  31
  32 : apply-filters ( links spider -- links' )
  33     filters>> [ '[ _ 1&& ] filter ] when* ;
  34
  35 : push-links ( links level assoc-heap -- )
  36     '[ _ _ heap-push ] each ;
  37
  38 : add-todo ( links level spider -- )
  39     todo>> push-links ;
  40
  41 : add-nonmatching ( links level spider -- )
  42     nonmatching>> push-links ;
  43
  44 : filter-base ( spider spider-result -- base-links nonmatching-links )
  45     [ base>> host>> ] [ links>> prune ] bi*
  46     [ host>> = ] with partition ;
  47
  48 : add-spidered ( spider spider-result -- )
  49     [ [ 1+ ] change-count ] dip
  50     2dup [ spidered>> ] [ dup url>> ] bi* rot set-at
  51     [ filter-base ] 2keep
  52     depth>> 1+ swap
  53     [ add-nonmatching ]
  54     [ tuck [ apply-filters ] 2dip add-todo ] 2bi ;
  55
  56 : normalize-hrefs ( links -- links' )
  57     [ >url ] map
  58     spider get base>> swap [ derive-url ] with map ;
  59
  60 : print-spidering ( url depth -- )
  61     "depth: " write number>string write
  62     ", spidering: " write . yield ;
  63
  64 : (spider-page) ( url depth -- spider-result )
  65     f pick spider get spidered>> set-at
  66     over '[ _ http-get ] benchmark swap
  67     [ parse-html dup find-hrefs normalize-hrefs ] benchmark
  68     now spider-result boa ;
  69
  70 : spider-page ( url depth -- )
  71     spider get quiet>> [ 2dup print-spidering ] unless
  72     (spider-page)
  73     spider get [ quiet>> [ dup describe ] unless ]
  74     [ swap add-spidered ] bi ;
  75
  76 \ spider-page ERROR add-error-logging
  77
  78 : spider-sleep ( -- )
  79     spider get sleep>> [ sleep ] when* ;
  80
  81 : queue-initial-links ( spider -- spider )
  82     [ initial-links>> normalize-hrefs 0 ] keep
  83     [ add-todo ] keep ;
  84
  85 : slurp-heap-when ( heap quot1 quot2: ( value key -- ) -- )
  86     pick heap-empty? [ 3drop ] [
  87         [ [ heap-pop dup ] 2dip slip [ t ] compose [ 2drop f ] if ]
  88         [ roll [ slurp-heap-when ] [ 3drop ] if ] 3bi
  89     ] if ; inline recursive
  90
  91 PRIVATE>
  92
  93 : run-spider ( spider -- spider )
  94     "spider" [
  95         dup spider [
  96             queue-initial-links
  97             [ todo>> ] [ max-depth>> ] bi
  98             '[
  99                 _ <= spider get
 100                 [ count>> ] [ max-count>> ] bi < and
 101             ] [ spider-page spider-sleep ] slurp-heap-when
 102             spider get
 103         ] with-variable
 104     ] with-logging ;