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