extra/spider/spider.factor

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