Merge branch 'master' of git://factorcode.org/git/factor
commit
eaf76aece1
extra
alarms
builder
db/sqlite
html/parser/analyzer
http
server
cgi
static
test
io/server
logging
analysis
insomniac
slides
unmaintained/webapps
numbers
|
@ -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? ;
|
||||
|
|
|
@ -102,7 +102,7 @@ SYMBOL: build-status
|
|||
|
||||
enter-build-dir
|
||||
|
||||
"report"
|
||||
"report" utf8
|
||||
[
|
||||
"Build machine: " write host-name print
|
||||
"CPU: " write cpu print
|
||||
|
|
|
@ -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
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -23,6 +23,5 @@ tuple-syntax namespaces ;
|
|||
[
|
||||
"http://www.apple.com/index.html"
|
||||
<get-request>
|
||||
request-with-url
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
<html><head><title>Hello</title></head><body>HTTPd test</body></html>
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 }
|
||||
}
|
||||
}
|
||||
|
|
|
@ -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/
|
|
@ -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/
|
|
@ -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/
|
Loading…
Reference in New Issue