! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors fry html.parser html.parser.analyzer
-http.client kernel tools.time sets assocs sequences
-concurrency.combinators io threads namespaces math multiline
-math.parser inspector urls logging combinators.short-circuit
-continuations calendar prettyprint dlists deques locals ;
+USING: accessors assocs calendar combinators.short-circuit
+concurrency.semaphores deques html.parser html.parser.analyzer
+http.client inspector io io.pathnames kernel logging math
+math.parser prettyprint sequences sets spider.unique-deque
+threads tools.time urls ;
IN: spider
-TUPLE: spider base count max-count sleep max-depth initial-links
-filters spidered todo nonmatching filtered quiet ;
-
-TUPLE: spider-result url depth headers fetch-time parsed-html
-links processing-time timestamp ;
-
-TUPLE: todo-url url depth ;
-
-: <todo-url> ( url depth -- todo-url )
- todo-url new
- swap >>depth
- swap >>url ;
-
-TUPLE: unique-deque assoc deque ;
-
-: <unique-deque> ( -- unique-deque )
- H{ } clone <dlist> unique-deque boa ;
-
-: push-url ( url depth unique-deque -- )
- [ <todo-url> ] dip
- [ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ]
- [ deque>> push-back ] 2bi ;
-
-: pop-url ( unique-deque -- todo-url ) deque>> pop-front ;
-
-: peek-url ( unique-deque -- todo-url ) deque>> peek-front ;
+TUPLE: spider
+ base
+ { count integer initial: 0 }
+ { max-count number initial: 1/0. }
+ sleep
+ { max-depth integer initial: 0 }
+ initial-links
+ filters
+ spidered
+ todo
+ nonmatching
+ quiet?
+ currently-spidering
+ { #threads integer initial: 1 }
+ semaphore
+ follow-robots?
+ robots ;
+
+TUPLE: spider-result url depth headers
+fetched-in parsed-html links processed-in fetched-at ;
: <spider> ( base -- spider )
>url
spider new
over >>base
+ over >>currently-spidering
swap 0 <unique-deque> [ push-url ] keep >>todo
<unique-deque> >>nonmatching
- <unique-deque> >>filtered
- 0 >>max-depth
- 0 >>count
- 1/0. >>max-count
- H{ } clone >>spidered ;
+ H{ } clone >>spidered
+ 1 <semaphore> >>semaphore ;
+
+: <spider-result> ( url depth -- spider-result )
+ spider-result new
+ swap >>depth
+ swap >>url ; inline
<PRIVATE
: apply-filters ( links spider -- links' )
- filters>> [ '[ [ _ 1&& ] filter ] call( seq -- seq' ) ] when* ;
+ filters>> [
+ '[ [ _ 1&& ] filter ] call( seq -- seq' )
+ ] when* ;
: push-links ( links level unique-deque -- )
'[ _ _ push-url ] each ;
: add-nonmatching ( links level spider -- )
nonmatching>> push-links ;
-: add-filtered ( links level spider -- )
- filtered>> push-links ;
-
: filter-base-links ( spider spider-result -- base-links nonmatching-links )
- [ base>> host>> ] [ links>> prune ] bi*
+ [ base>> host>> ] [ links>> members ] bi*
[ host>> = ] with partition ;
-: add-spidered ( spider spider-result -- )
- [ [ 1+ ] change-count ] dip
- 2dup [ spidered>> ] [ dup url>> ] bi* rot set-at
- [ filter-base-links ] 2keep
- depth>> 1+ swap
- [ add-nonmatching ]
- [ tuck [ apply-filters ] 2dip add-todo ] 2bi ;
+:: add-spidered ( spider spider-result -- )
+ spider [ 1 + ] change-count drop
+
+ spider-result dup url>>
+ spider spidered>> set-at
+
+ spider spider-result filter-base-links :> ( matching nonmatching )
+ spider-result depth>> 1 + :> depth
-: normalize-hrefs ( links spider -- links' )
- [ [ >url ] map ] dip
- base>> swap [ derive-url ] with map ;
+ nonmatching depth spider add-nonmatching
-: print-spidering ( url depth -- )
+ matching spider apply-filters depth spider add-todo ;
+
+: normalize-hrefs ( base links -- links' )
+ [ derive-url ] with map ;
+
+: print-spidering ( spider-result -- )
+ [ url>> ] [ depth>> ] bi
"depth: " write number>string write
", spidering: " write . yield ;
-:: new-spidered-result ( spider url depth -- spider-result )
+: url-html? ( url -- ? )
+ path>> file-extension { ".htm" ".html" f } member? ;
+
+:: fill-spidered-result ( spider spider-result -- )
+ spider-result url>> :> url
f url spider spidered>> set-at
- [ url http-get ] benchmark :> fetch-time :> html :> headers
+ [ url http-get ] benchmark :> ( headers html fetched-in )
[
- html parse-html [ ] [ find-hrefs spider normalize-hrefs ] bi
- ] benchmark :> processing-time :> links :> parsed-html
- url depth headers fetch-time parsed-html links processing-time
- now spider-result boa ;
-
-:: spider-page ( spider url depth -- )
- spider quiet>> [ url depth print-spidering ] unless
- spider url depth new-spidered-result :> spidered-result
- spider quiet>> [ spidered-result describe ] unless
- spider spidered-result add-spidered ;
+ url url-html? [
+ html parse-html
+ spider currently-spidering>>
+ over find-all-links normalize-hrefs
+ ] [
+ f { }
+ ] if
+ ] benchmark :> ( parsed-html links processed-in )
+ spider-result
+ headers >>headers
+ fetched-in >>fetched-in
+ parsed-html >>parsed-html
+ links >>links
+ processed-in >>processed-in
+ now >>fetched-at drop ;
+
+:: spider-page ( spider spider-result -- )
+ spider quiet?>> [ spider-result print-spidering ] unless
+ spider spider-result fill-spidered-result
+ spider quiet?>> [ spider-result describe ] unless
+ spider spider-result add-spidered ;
\ spider-page ERROR add-error-logging
-: spider-sleep ( spider -- )
- sleep>> [ sleep ] when* ;
+: spider-sleep ( spider -- ) sleep>> [ sleep ] when* ;
-:: queue-initial-links ( spider -- spider )
- spider initial-links>> spider normalize-hrefs 0 spider add-todo spider ;
+: queue-initial-links ( spider -- spider )
+ [ [ currently-spidering>> ] [ initial-links>> ] bi normalize-hrefs 0 ]
+ [ add-todo ]
+ [ ] tri ;
: spider-page? ( spider -- ? )
{
[ todo>> deque>> deque-empty? not ]
- [ [ todo>> peek-url depth>> ] [ max-depth>> ] bi < ]
+ [ [ todo>> peek-url depth>> ] [ max-depth>> ] bi <= ]
+ [ [ count>> ] [ max-count>> ] bi < ]
} 1&& ;
-: setup-next-url ( spider -- spider url depth )
- dup todo>> pop-url [ url>> ] [ depth>> ] bi ;
+: setup-next-url ( spider -- spider spider-result )
+ dup todo>> peek-url url>> >>currently-spidering
+ dup todo>> pop-url [ url>> ] [ depth>> ] bi <spider-result> ;
: spider-next-page ( spider -- )
- setup-next-url spider-page ;
+ setup-next-url
+ spider-page ;
PRIVATE>
: run-spider-loop ( spider -- )
dup spider-page? [
- [ spider-next-page ] [ run-spider-loop ] bi
+ [ spider-next-page ] [ spider-sleep ] [ run-spider-loop ] tri
] [
drop
] if ;
: run-spider ( spider -- spider )
"spider" [
- queue-initial-links [ run-spider-loop ] keep
+ queue-initial-links
+ [ run-spider-loop ] keep
] with-logging ;
projects / factor.git / blobdiff