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

extra/alarms/alarms.factor

@@ -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? ;

extra/http/client/client-tests.factor

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

extra/http/client/client.factor

@@ -6,72 +6,76 @@ 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 )
+: request-addr ( request -- addr )
-    dup host>> over port>> <inet> latin1 <client> stdio set
+    dup host>> swap port>> <inet> ;
-    dup "r" set-global  write-request flush read-response
+
-    do-redirect ;
+: close-on-error ( stream quot -- )
+    [ with-stream* ] curry [ ] pick [ dispose ] curry cleanup ;
+    inline
 
 PRIVATE>
 
-: http-request ( url request -- response stream )
+: http-request ( request -- response stream )
-    [
+    dup request [
-        request-with-url
+        dup request-addr latin1 <client>
+        1 minutes over set-timeout
         [
-            (http-request)
+            write-request flush
-            1 minutes over set-timeout
+            read-response
-        ] [ ] [ stdio get dispose ] cleanup
+            do-redirect
-    ] with-scope ;
+        ] close-on-error
+    ] with-variable ;
 
-: <get-request> ( -- request )
+: <get-request> ( url -- request )
-    <request> "GET" >>method ;
+    <request> request-with-url "GET" >>method ;
 
 : http-get-stream ( url -- response stream )
     <get-request> http-request ;
 
 : success? ( code -- ? ) 200 = ;
 
-: check-response ( response stream -- stream )
+: check-response ( response -- )
-    swap code>> success?
+    code>> success?
-    [ dispose "HTTP download failed" throw ] unless ;
+    [ "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 ;
@@ -84,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 ;

extra/http/http-tests.factor

@@ -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

extra/http/server/cgi/cgi.factor

@@ -41,18 +41,17 @@ IN: http.server.cgi
         ] when
     ] H{ } make-assoc ;
 
-: cgi-descriptor ( name -- desc )
+: <cgi-process> ( name -- desc )
-    [
+    <process>
-        dup 1array +arguments+ set
+        over 1array >>command
-        cgi-variables +environment+ set
+        swap cgi-variables >>environment ;
-    ] H{ } make-assoc ;
     
 : 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

extra/http/server/static/static.factor

@@ -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 )

extra/http/test/foo.html

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

extra/io/server/server.factor

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

extra/logging/analysis/analysis.factor

@@ -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.
-    [
+    "====== " write
-        dup first [ write ] with-cell
+    dup first (timestamp>string) bl
-        dup second [ pprint ] with-cell
+    dup second pprint bl
-        dup third [ write ] with-cell
+    dup third write nl
-        fourth "\n" join [ write ] with-cell
+    fourth "\n" join print ;
-    ] with-row ;
 
 : errors. ( errors -- )
-    standard-table-style
+    [ log-entry. ] each ;
-    [ [ log-entry. ] each ] tabular-output ;
 
 : analysis. ( errors word-histogram message-histogram -- )
     "==== INTERESTING MESSAGES:" print nl

extra/logging/insomniac/insomniac.factor

@@ -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
+USING: logging.analysis logging.server logging smtp kernel
-kernel io.files io.streams.string namespaces raptor.cron assocs
+io.files io.streams.string namespaces alarms assocs
-io.encodings.utf8 ;
+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
+        dupd ?analyze-log dup [
-        ?analyze-log dup [
+            <email>
-            r> email-subject
+                swap >>body
-            insomniac-recipients get
+                insomniac-recipients get >>to
-            insomniac-sender get
+                insomniac-sender get >>from
-            send-simple-message
+                swap email-subject >>subject
-        ] [ r> 2drop ] if
+            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
-        [ email-log-report ] assoc-each rotate-logs
+    1 days every drop ;
-    ] 2curry schedule ;

extra/slides/slides.factor

@@ -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 }
             }
         }

misc/macos-release.sh

@@ -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/

misc/source-release.sh

@@ -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/

misc/windows-release.sh

@@ -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/