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 ;
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 ;
15 TUPLE: spider-result url depth headers
16 fetched-in parsed-html links processed-in fetched-at ;
18 : <spider> ( base -- spider )
22 over >>currently-spidering
23 swap 0 <unique-deque> [ push-url ] keep >>todo
24 <unique-deque> >>nonmatching
29 1 [ >>#threads ] [ <semaphore> >>semaphore ] bi ;
31 : <spider-result> ( url depth -- spider-result )
38 : apply-filters ( links spider -- links' )
39 filters>> [ '[ [ _ 1&& ] filter ] call( seq -- seq' ) ] when* ;
41 : push-links ( links level unique-deque -- )
42 '[ _ _ push-url ] each ;
44 : add-todo ( links level spider -- )
47 : add-nonmatching ( links level spider -- )
48 nonmatching>> push-links ;
50 : filter-base-links ( spider spider-result -- base-links nonmatching-links )
51 [ base>> host>> ] [ links>> prune ] bi*
52 [ host>> = ] with partition ;
54 : add-spidered ( spider spider-result -- )
55 [ [ 1+ ] change-count ] dip
56 2dup [ spidered>> ] [ dup url>> ] bi* rot set-at
57 [ filter-base-links ] 2keep
60 [ tuck [ apply-filters ] 2dip add-todo ] 2bi ;
62 : normalize-hrefs ( base links -- links' )
63 [ derive-url ] with map ;
65 : print-spidering ( spider-result -- )
66 [ url>> ] [ depth>> ] bi
67 "depth: " write number>string write
68 ", spidering: " write . yield ;
70 :: fill-spidered-result ( spider spider-result -- )
71 f spider-result url>> spider spidered>> set-at
72 [ spider-result url>> http-get ] benchmark :> fetched-in :> html :> headers
75 spider currently-spidering>>
76 over find-all-links normalize-hrefs
77 ] benchmark :> processed-in :> links :> parsed-html
80 fetched-in >>fetched-in
81 parsed-html >>parsed-html
83 processed-in >>processed-in
84 now >>fetched-at drop ;
86 :: spider-page ( spider spider-result -- )
87 spider quiet>> [ spider-result print-spidering ] unless
88 spider spider-result fill-spidered-result
89 spider quiet>> [ spider-result describe ] unless
90 spider spider-result add-spidered ;
92 \ spider-page ERROR add-error-logging
94 : spider-sleep ( spider -- ) sleep>> [ sleep ] when* ;
96 : queue-initial-links ( spider -- )
98 [ currently-spidering>> ] [ initial-links>> ] bi normalize-hrefs 0
101 : spider-page? ( spider -- ? )
103 [ todo>> deque>> deque-empty? not ]
104 [ [ todo>> peek-url depth>> ] [ max-depth>> ] bi < ]
105 [ [ count>> ] [ max-count>> ] bi < ]
108 : setup-next-url ( spider -- spider spider-result )
109 dup todo>> peek-url url>> >>currently-spidering
110 dup todo>> pop-url [ url>> ] [ depth>> ] bi <spider-result> ;
112 : spider-next-page ( spider -- )
113 setup-next-url spider-page ;
117 : run-spider-loop ( spider -- )
119 [ spider-next-page ] [ spider-sleep ] [ run-spider-loop ] tri
124 : run-spider ( spider -- spider )
126 dup queue-initial-links [ run-spider-loop ] keep