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