Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-03-07 20:10:47 -06:00
commit eaf76aece1
55 changed files with 120 additions and 150 deletions

View File

@ -85,5 +85,8 @@ PRIVATE>
: later ( quot dt -- alarm )
from-now f add-alarm ;
: every ( quot dt -- alarm )
[ from-now ] keep add-alarm ;
: cancel-alarm ( alarm -- )
alarm-entry [ alarms get-global heap-delete ] if-box? ;

View File

@ -102,7 +102,7 @@ SYMBOL: build-status
enter-build-dir
"report"
"report" utf8
[
"Build machine: " write host-name print
"CPU: " write cpu print

View File

@ -6,22 +6,24 @@ USING: kernel namespaces sequences assocs builder continuations
prettyprint
tools.browser
tools.test
io.encodings.utf8
bootstrap.stage2 benchmark builder.util ;
IN: builder.test
: do-load ( -- )
try-everything keys "../load-everything-vocabs" [ . ] with-file-writer ;
try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ;
: do-tests ( -- )
run-all-tests keys "../test-all-vocabs" [ . ] with-file-writer ;
run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ;
: do-benchmarks ( -- ) run-benchmarks "../benchmarks" [ . ] with-file-writer ;
: do-benchmarks ( -- )
run-benchmarks "../benchmarks" utf8 [ . ] with-file-writer ;
: do-all ( -- )
bootstrap-time get "../boot-time" [ . ] with-file-writer
[ do-load ] runtime "../load-time" [ . ] with-file-writer
[ do-tests ] runtime "../test-time" [ . ] with-file-writer
bootstrap-time get "../boot-time" utf8 [ . ] with-file-writer
[ do-load ] runtime "../load-time" utf8 [ . ] with-file-writer
[ do-tests ] runtime "../test-time" utf8 [ . ] with-file-writer
do-benchmarks ;
MAIN: do-all

View File

@ -70,7 +70,7 @@ DEFER: to-strings
: milli-seconds>time ( n -- string )
1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
: eval-file ( file -- obj ) file-contents eval ;
: eval-file ( file -- obj ) utf8 file-contents eval ;
: cat ( file -- ) utf8 file-contents print ;

View File

@ -5,7 +5,7 @@ hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings tuples alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators tools.walker
combinators.cleave io ;
combinators.cleave io namespaces.lib ;
IN: db.sqlite
TUPLE: sqlite-db path ;

View File

@ -1,5 +1,6 @@
USING: assocs html.parser kernel math sequences strings ascii
arrays shuffle unicode.case namespaces splitting http ;
arrays shuffle unicode.case namespaces splitting http
sequences.lib ;
IN: html.parser.analyzer
: (find-relative)

View File

@ -23,6 +23,5 @@ tuple-syntax namespaces ;
[
"http://www.apple.com/index.html"
<get-request>
request-with-url
] with-scope
] unit-test

View File

@ -2,75 +2,80 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files io.timeouts strings
splitting calendar continuations accessors vectors io.encodings.binary ;
splitting calendar continuations accessors vectors io.encodings.latin1
io.encodings.binary ;
IN: http.client
DEFER: http-request
<PRIVATE
: parse-url ( url -- resource host port )
"http://" ?head [ "Only http:// supported" throw ] unless
"/" split1 [ "/" swap append ] [ "/" ] if*
swap parse-host ;
<PRIVATE
: store-path ( request path -- request )
"?" split1 >r >>path r> dup [ query>assoc ] when >>query ;
! This is all pretty complex because it needs to handle
! HTTP redirects, which might be absolute or relative
: request-with-url ( url request -- request )
clone dup "request" set
swap parse-url >r >r store-path r> >>host r> >>port ;
DEFER: (http-request)
! This is all pretty complex because it needs to handle
! HTTP redirects, which might be absolute or relative
: absolute-redirect ( url -- request )
"request" get request-with-url ;
request get request-with-url ;
: relative-redirect ( path -- request )
"request" get swap store-path ;
request get swap store-path ;
: do-redirect ( response -- response stream )
dup response-code 300 399 between? [
stdio get dispose
header>> "location" swap at
dup "http://" head? [
absolute-redirect
] [
relative-redirect
] if "GET" >>method (http-request)
] if "GET" >>method http-request
] [
stdio get
] if ;
: (http-request) ( request -- response stream )
dup host>> over port>> <inet> <client> stdio set
dup "r" set-global write-request flush read-response
do-redirect ;
: request-addr ( request -- addr )
dup host>> swap port>> <inet> ;
: close-on-error ( stream quot -- )
[ with-stream* ] curry [ ] pick [ dispose ] curry cleanup ;
inline
PRIVATE>
: http-request ( url request -- response stream )
[
request-with-url
: http-request ( request -- response stream )
dup request [
dup request-addr latin1 <client>
1 minutes over set-timeout
[
(http-request)
1 minutes over set-timeout
] [ ] [ stdio get dispose ] cleanup
] with-scope ;
write-request flush
read-response
do-redirect
] close-on-error
] with-variable ;
: <get-request> ( -- request )
<request> "GET" >>method ;
: <get-request> ( url -- request )
<request> request-with-url "GET" >>method ;
: http-get-stream ( url -- response stream )
<get-request> http-request ;
: success? ( code -- ? ) 200 = ;
: check-response ( response stream -- stream )
swap code>> success?
[ dispose "HTTP download failed" throw ] unless ;
: check-response ( response -- )
code>> success?
[ "HTTP download failed" throw ] unless ;
: http-get ( url -- string )
http-get-stream check-response contents ;
http-get-stream contents swap check-response ;
: download-name ( url -- name )
file-name "?" split1 drop "/" ?tail drop ;
@ -83,12 +88,13 @@ PRIVATE>
: download ( url -- )
dup download-name download-to ;
: <post-request> ( content-type content -- request )
: <post-request> ( content-type content url -- request )
<request>
request-with-url
"POST" >>method
swap >>post-data
swap >>post-data-type ;
: http-post ( content-type content url -- response string )
#! The content is URL encoded for you.
-rot url-encode <post-request> http-request contents ;
>r url-encode r> <post-request> http-request contents ;

View File

@ -127,3 +127,30 @@ read-response-test-1' 1array [
"rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT"
dup parse-cookies unparse-cookies =
] unit-test
! Live-fire exercise
USING: http.server http.server.static http.server.actions
http.client io.server io.files io accessors namespaces threads
io.encodings.ascii ;
[ ] [
[
<dispatcher>
<action>
[ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>get
"quit" add-responder
"extra/http/test" resource-path <static> >>default
default-host set
[ 1237 httpd ] "HTTPD test" spawn drop
] with-scope
] unit-test
[ t ] [
"extra/http/test/foo.html" resource-path ascii file-contents
"http://localhost:1237/foo.html" http-get =
] unit-test
[ "Goodbye" ] [
"http://localhost:1237/quit" http-get
] unit-test

View File

@ -41,18 +41,17 @@ IN: http.server.cgi
] when
] H{ } make-assoc ;
: cgi-descriptor ( name -- desc )
[
dup 1array +arguments+ set
cgi-variables +environment+ set
] H{ } make-assoc ;
: <cgi-process> ( name -- desc )
<process>
over 1array >>command
swap cgi-variables >>environment ;
: serve-cgi ( name -- response )
<raw-response>
200 >>code
"CGI output follows" >>message
swap [
stdio get swap cgi-descriptor <process-stream> [
stdio get swap <cgi-process> <process-stream> [
post? [
request get post-data>> write flush
] when

View File

@ -3,7 +3,7 @@
USING: calendar html io io.files kernel math math.parser http
http.server namespaces parser sequences strings assocs
hashtables debugger http.mime sorting html.elements logging
calendar.format new-slots accessors ;
calendar.format new-slots accessors io.encodings.binary ;
IN: http.server.static
SYMBOL: responder
@ -33,7 +33,7 @@ TUPLE: file-responder root hook special ;
<content>
over file-length "content-length" set-header
over file-http-date "last-modified" set-header
swap [ <file-reader> stdio get stream-copy ] curry >>body
swap [ binary <file-reader> stdio get stream-copy ] curry >>body
] <file-responder> ;
: serve-static ( filename mime-type -- response )

1
extra/http/test/foo.html Normal file
View File

@ -0,0 +1 @@
<html><head><title>Hello</title></head><body>HTTPd test</body></html>

View File

@ -40,11 +40,11 @@ PRIVATE>
f swap t resolve-host ;
: with-server ( seq service encoding quot -- )
V{ } clone [
swap servers [
V{ } clone servers [
[
[ server-loop ] 2curry with-logging
] with-variable
] 3curry curry parallel-each ; inline
] 3curry parallel-each
] with-variable ; inline
: stop-server ( -- )
servers get [ dispose ] each ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences namespaces words assocs logging sorting
prettyprint io io.styles strings logging.parser ;
prettyprint io io.styles strings logging.parser calendar.format ;
IN: logging.analysis
SYMBOL: word-names
@ -42,16 +42,14 @@ SYMBOL: message-histogram
] tabular-output ;
: log-entry.
[
dup first [ write ] with-cell
dup second [ pprint ] with-cell
dup third [ write ] with-cell
fourth "\n" join [ write ] with-cell
] with-row ;
"====== " write
dup first (timestamp>string) bl
dup second pprint bl
dup third write nl
fourth "\n" join print ;
: errors. ( errors -- )
standard-table-style
[ [ log-entry. ] each ] tabular-output ;
[ log-entry. ] each ;
: analysis. ( errors word-histogram message-histogram -- )
"==== INTERESTING MESSAGES:" print nl

View File

@ -1,8 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: logging.analysis logging.server logging smtp io.sockets
kernel io.files io.streams.string namespaces raptor.cron assocs
io.encodings.utf8 ;
USING: logging.analysis logging.server logging smtp kernel
io.files io.streams.string namespaces alarms assocs
io.encodings.utf8 accessors calendar qualified ;
QUALIFIED: io.sockets
IN: logging.insomniac
SYMBOL: insomniac-smtp-host
@ -25,17 +26,20 @@ SYMBOL: insomniac-recipients
] with-scope ; inline
: email-subject ( service -- string )
[ "[INSOMNIAC] " % % " on " % host-name % ] "" make ;
[
"[INSOMNIAC] " % % " on " % io.sockets:host-name %
] "" make ;
: (email-log-report) ( service word-names -- )
[
over >r
?analyze-log dup [
r> email-subject
insomniac-recipients get
insomniac-sender get
send-simple-message
] [ r> 2drop ] if
dupd ?analyze-log dup [
<email>
swap >>body
insomniac-recipients get >>to
insomniac-sender get >>from
swap email-subject >>subject
send
] [ 2drop ] if
] with-insomniac-smtp ;
\ (email-log-report) NOTICE add-error-logging
@ -44,6 +48,5 @@ SYMBOL: insomniac-recipients
"logging.insomniac" [ (email-log-report) ] with-logging ;
: schedule-insomniac ( service word-names -- )
{ 25 } { 6 } f f f <when> -rot [
[ email-log-report ] assoc-each rotate-logs
] 2curry schedule ;
[ [ email-log-report ] assoc-each rotate-logs ] 2curry
1 days every drop ;

View File

@ -6,10 +6,14 @@ IN: slides
: stylesheet
H{
{ default-style
{ default-span-style
H{
{ font "sans-serif" }
{ font-size 36 }
}
}
{ default-block-style
H{
{ wrap-margin 1000 }
}
}

View File

@ -1,35 +0,0 @@
source misc/version.sh
TARGET=$1
if [ "$1" = "x86" ]; then
CPU="x86.32"
TARGET=macosx-x86-32
else
CPU="macosx-ppc"
TARGET=macosx-ppc
fi
BOOT_IMAGE=boot.$CPU.image
wget http://factorcode.org/images/$VERSION/$BOOT_IMAGE
make $TARGET
Factor.app/Contents/MacOS/factor -i=$BOOT_IMAGE -no-user-init
DISK_IMAGE_DIR=Factor-$VERSION
DISK_IMAGE=Factor-$VERSION-$TARGET.dmg
rm -f $DISK_IMAGE
rm -rf $DISK_IMAGE_DIR
mkdir $DISK_IMAGE_DIR
mkdir -p $DISK_IMAGE_DIR/Factor/
cp -R Factor.app $DISK_IMAGE_DIR/Factor/Factor.app
chmod +x cp_dir
cp factor.image license.txt README.txt $DISK_IMAGE_DIR/Factor/
find core extra fonts misc unmaintained -type f \
-exec ./cp_dir {} $DISK_IMAGE_DIR/Factor/{} \;
hdiutil create -srcfolder "$DISK_IMAGE_DIR" -fs HFS+ \
-volname "$DISK_IMAGE_DIR" "$DISK_IMAGE"
ssh linode mkdir -p w/downloads/$VERSION/
scp $DISK_IMAGE linode:w/downloads/$VERSION/

View File

@ -1,7 +0,0 @@
source misc/version.sh
rm -rf .git .gitignore
cd ..
tar cfz Factor-$VERSION.tar.gz factor/
ssh linode mkdir -p w/downloads/$VERSION/
scp Factor-$VERSION.tar.gz linode:w/downloads/$VERSION/

View File

@ -1,31 +0,0 @@
source misc/version.sh
CPU=$1
if [ "$CPU" = "x86" ]; then
FLAGS="-no-sse2"
fi
make windows-nt-x86-32
wget http://factorcode.org/dlls/freetype6.dll
wget http://factorcode.org/dlls/zlib1.dll
wget http://factorcode.org/images/$VERSION/boot.x86.32.image
CMD="./factor-nt -i=boot.x86.32.image -no-user-init $FLAGS"
echo $CMD
$CMD
rm -rf .git/ .gitignore
rm -rf Factor.app/
rm -rf vm/
rm -f Makefile
rm -f cp_dir
rm -f boot.*.image
FILE=Factor-$VERSION-win32-$CPU.zip
cd ..
zip -r $FILE Factor/
ssh linode mkdir -p w/downloads/$VERSION/
scp $FILE linode:w/downloads/$VERSION/