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 math.parser inspector urls logging combinators.short-circuit
   7 continuations calendar prettyprint dlists deques locals
   8 spider.unique-deque ;
   9 IN: spider
  10
  11 TUPLE: spider base count max-count sleep max-depth initial-links
  12 filters spidered todo nonmatching quiet currently-spidering
  13 #threads follow-robots? robots ;
  14
  15 TUPLE: spider-result url depth headers
  16 fetched-in parsed-html links processed-in fetched-at ;
  17
  18 TUPLE: todo-url url depth ;
  19
  20 : <todo-url> ( url depth -- todo-url )
  21     todo-url new
  22         swap >>depth
  23         swap >>url ;
  24
  25 : <spider> ( base -- spider )
  26     >url
  27     spider new
  28         over >>base
  29         over >>currently-spidering
  30         swap 0 <unique-deque> [ push-url ] keep >>todo
  31         <unique-deque> >>nonmatching
  32         0 >>max-depth
  33         0 >>count
  34         1/0. >>max-count
  35         H{ } clone >>spidered
  36         1 >>#threads ;
  37
  38 <PRIVATE
  39
  40 : apply-filters ( links spider -- links' )
  41     filters>> [ '[ [ _ 1&& ] filter ] call( seq -- seq' ) ] when* ;
  42
  43 : push-links ( links level unique-deque -- )
  44     '[ _ _ push-url ] each ;
  45
  46 : add-todo ( links level spider -- )
  47     todo>> push-links ;
  48
  49 : add-nonmatching ( links level spider -- )
  50     nonmatching>> push-links ;
  51
  52 : filter-base-links ( spider spider-result -- base-links nonmatching-links )
  53     [ base>> host>> ] [ links>> prune ] bi*
  54     [ host>> = ] with partition ;
  55
  56 : add-spidered ( spider spider-result -- )
  57     [ [ 1+ ] change-count ] dip
  58     2dup [ spidered>> ] [ dup url>> ] bi* rot set-at
  59     [ filter-base-links ] 2keep
  60     depth>> 1+ swap
  61     [ add-nonmatching ]
  62     [ tuck [ apply-filters ] 2dip add-todo ] 2bi ;
  63
  64 : normalize-hrefs ( base links -- links' )
  65     [ derive-url ] with map ;
  66
  67 : print-spidering ( url depth -- )
  68     "depth: " write number>string write
  69     ", spidering: " write . yield ;
  70
  71 :: new-spidered-result ( spider url depth -- spider-result )
  72     f url spider spidered>> set-at
  73     [ url http-get ] benchmark :> fetched-at :> html :> headers
  74     [
  75         html parse-html
  76         spider currently-spidering>>
  77         over find-all-links normalize-hrefs
  78     ] benchmark :> processing-time :> links :> parsed-html
  79     url depth headers fetched-at parsed-html links processing-time
  80     now spider-result boa ;
  81
  82 :: spider-page ( spider url depth -- )
  83     spider quiet>> [ url depth print-spidering ] unless
  84     spider url depth new-spidered-result :> spidered-result
  85     spider quiet>> [ spidered-result describe ] unless
  86     spider spidered-result add-spidered ;
  87
  88 \ spider-page ERROR add-error-logging
  89
  90 : spider-sleep ( spider -- ) sleep>> [ sleep ] when* ;
  91
  92 : queue-initial-links ( spider -- )
  93     [
  94         [ currently-spidering>> ] [ initial-links>> ] bi normalize-hrefs 0
  95     ] keep add-todo ;
  96
  97 : spider-page? ( spider -- ? )
  98     {
  99         [ todo>> deque>> deque-empty? not ]
 100         [ [ todo>> peek-url depth>> ] [ max-depth>> ] bi < ]
 101         [ [ count>> ] [ max-count>> ] bi < ]
 102     } 1&& ;
 103
 104 : setup-next-url ( spider -- spider url depth )
 105     dup todo>> peek-url url>> >>currently-spidering
 106     dup todo>> pop-url [ url>> ] [ depth>> ] bi ;
 107
 108 : spider-next-page ( spider -- )
 109     setup-next-url spider-page ;
 110
 111 PRIVATE>
 112
 113 : run-spider-loop ( spider -- )
 114     dup spider-page? [
 115         [ spider-next-page ] [ spider-sleep ] [ run-spider-loop ] tri
 116     ] [
 117         drop
 118     ] if ;
 119
 120 : run-spider ( spider -- spider )
 121     "spider" [
 122         dup queue-initial-links [ run-spider-loop ] keep
 123     ] with-logging ;