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