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