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

core/bootstrap/image/image.factor

@@ -10,6 +10,23 @@ definitions debugger float-arrays quotations.private
 combinators.private combinators ;
 IN: bootstrap.image
 
+: my-arch ( -- arch )
+    cpu dup "ppc" = [ os "-" rot 3append ] when ;
+
+: boot-image-name ( arch -- string )
+    "boot." swap ".image" 3append ;
+
+: my-boot-image-name ( -- string )
+    my-arch boot-image-name ;
+
+: images ( -- seq )
+    {
+        "x86.32"
+        "x86.64"
+        "linux-ppc" "macosx-ppc"
+        ! "arm"
+    } ;
+
 <PRIVATE
 
 ! Constants
@@ -394,9 +411,6 @@ M: curry '
         [ >le write ] curry each
     ] if ;
 
-: image-name
-    "boot." architecture get ".image" 3append resource-path ;
-
 : write-image ( image filename -- )
     "Writing image to " write dup write "..." print flush
     <file-writer> [ (write-image) ] with-stream ;
@@ -415,16 +429,10 @@ PRIVATE>
         begin-image
         "resource:/core/bootstrap/stage1.factor" run-file
         end-image
-        image get image-name write-image
+        image get
+        architecture get boot-image-name resource-path
+        write-image
     ] with-variable ;
 
-: my-arch ( -- arch )
-    cpu dup "ppc" = [ os "-" rot 3append ] when ;
-
 : make-images ( -- )
-    {
-        "x86.32"
-        "x86.64"
-        "linux-ppc" "macosx-ppc"
-        ! "arm"
-    } [ make-image ] each ;
+    images [ make-image ] each ;

extra/benchmark/bootstrap2/bootstrap2.factor

@@ -1,4 +1,4 @@
-USING: io.files io.launcher system tools.deploy.backend
+USING: io.files io.launcher system bootstrap.image
 namespaces sequences kernel ;
 IN: benchmark.bootstrap2
 
@@ -6,7 +6,7 @@ IN: benchmark.bootstrap2
     "." resource-path cd
     [
         vm ,
-        "-i=" boot-image-name append ,
+        "-i=" my-boot-image-name append ,
         "-output-image=foo.image" ,
         "-no-user-init" ,
     ] { } make run-process drop ;

extra/bootstrap/image/download/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/bootstrap/image/download/download.factor

@@ -0,0 +1,25 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: bootstrap.image.download
+USING: http.client crypto.md5 splitting assocs kernel io.files
+bootstrap.image sequences io ;
+
+: url "http://factorcode.org/images/latest/" ;
+
+: download-checksums ( -- alist )
+    url "checksums.txt" append http-get
+    string-lines [ " " split1 ] { } map>assoc ;
+
+: need-new-image? ( image -- ? )
+    dup exists?
+    [ dup file>md5str swap download-checksums at = not ]
+    [ drop t ] if ;
+
+: download-image ( arch -- )
+    boot-image-name dup need-new-image? [
+        "Downloading " write dup write "..." print
+        url swap append download
+    ] [
+        "Boot image up to date" print
+        drop
+    ] if ;

extra/bootstrap/image/download/summary.txt

@@ -0,0 +1 @@
+Smart image downloader utility which first checks MD5 checksum

extra/bootstrap/image/upload/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/bootstrap/image/upload/summary.txt

@@ -0,0 +1 @@
+Image upload utility

extra/bootstrap/image/upload/upload.factor

@@ -0,0 +1,25 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: bootstrap.image.upload
+USING: http.client crypto.md5 splitting assocs kernel io.files
+bootstrap.image sequences io namespaces io.launcher math ;
+
+: destination "slava@factorcode.org:www/images/latest/" ;
+
+: boot-image-names images [ boot-image-name ] map ;
+
+: compute-checksums ( -- )
+    "checksums.txt" [
+        boot-image-names [ dup write bl file>md5str print ] each
+    ] with-file-out ;
+
+: upload-images ( -- )
+    [
+        "scp" , boot-image-names % "checksums.txt" , destination ,
+    ] { } make run-process
+    wait-for-process zero? [ "Upload failed" throw ] unless ;
+
+: new-images ( -- )
+    make-images compute-checksums upload-images ;
+
+MAIN: new-images

extra/crypto/sha1/sha1.factor

@@ -48,14 +48,13 @@ SYMBOL: K
 ! f(t;B,C,D) = (B AND C) OR (B AND D) OR (C AND D)  (40 <= t <= 59)
 ! f(t;B,C,D) = B XOR C XOR D                        (60 <= t <= 79)
 : sha1-f ( B C D t -- f_tbcd )
-    #! Maybe use dispatch
     20 /i
     {   
-        { [ dup 0 = ] [ drop >r over bitnot r> bitand >r bitand r> bitor ] }
-        { [ dup 1 = ] [ drop bitxor bitxor ] }
-        { [ dup 2 = ] [ drop 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] }
-        { [ dup 3 = ] [ drop bitxor bitxor ] }
-    } cond ;
+        { 0 [ >r over bitnot r> bitand >r bitand r> bitor ] }
+        { 1 [ bitxor bitxor ] }
+        { 2 [ 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] }
+        { 3 [ bitxor bitxor ] }
+    } case ;
 
 : make-w ( str -- )
     #! compute w, steps a-b of RFC 3174, section 6.1

extra/http/client/client.factor

@@ -47,32 +47,31 @@ DEFER: http-get-stream
         dispose "location" swap peek-at nip http-get-stream
     ] when ;
 
+: default-timeout 60 1000 * over set-timeout ;
+
 : http-get-stream ( url -- code headers stream )
     #! Opens a stream for reading from an HTTP URL.
     parse-url over parse-host <inet> <client> [
         [ [ get-request read-response ] with-stream* ] keep
+        default-timeout
     ] [ ] [ dispose ] cleanup do-redirect ;
 
-: http-get ( url -- code headers string )
-    #! Opens a stream for reading from an HTTP URL.
-    [
-        http-get-stream [ stdio get contents ] with-stream
-    ] with-scope ;
+: success? ( code -- ? ) 200 = ;
+
+: check-response ( code headers stream -- stream )
+    nip swap success?
+    [ dispose "HTTP download failed" throw ] unless ;
+
+: http-get ( url -- string )
+    http-get-stream check-response contents ;
 
 : download-name ( url -- name )
     file-name "?" split1 drop "/" ?tail drop ;
 
-: default-timeout 60 1000 * over set-timeout ;
-
-: success? ( code -- ? ) 200 = ;
-
 : download-to ( url file -- )
     #! Downloads the contents of a URL to a file.
-    >r http-get-stream nip default-timeout swap success? [
-        r> <file-writer> stream-copy
-    ] [
-        r> drop dispose "HTTP download failed" throw
-    ] if ;
+    >r http-get-stream check-response
+    r> <file-writer> stream-copy ;
 
 : download ( url -- )
     dup download-name download-to ;

extra/io/server/server.factor

@@ -19,7 +19,8 @@ LOG: accepted-connection NOTICE
 
 : accept-loop ( server quot -- )
     [
-        >r accept r> [ with-client ] 2curry concurrency:spawn
+        >r accept r> [ with-client ] 2curry
+        concurrency:spawn drop
     ] 2keep accept-loop ; inline
 
 : server-loop ( server quot -- )

extra/rss/rss.factor

@@ -78,7 +78,7 @@ C: <entry> entry
 
 : download-feed ( url -- feed )
     #! Retrieve an news syndication file, return as a feed tuple.
-    http-get-stream rot 200 = [
+    http-get-stream rot success? [
         nip read-feed
     ] [
         2drop "Error retrieving newsfeed file" throw

extra/tools/deploy/backend/backend.factor

@@ -24,12 +24,9 @@ IN: tools.deploy.backend
     dup duplex-stream-out dispose
     copy-lines ;
 
-: boot-image-name ( -- string )
-    "boot." my-arch ".image" 3append ;
-
 : make-boot-image ( -- )
     #! If stage1 image doesn't exist, create one.
-    boot-image-name resource-path exists?
+    my-boot-image-name resource-path exists?
     [ my-arch make-image ] unless ;
 
 : ?, [ , ] [ drop ] if ;
@@ -49,7 +46,7 @@ IN: tools.deploy.backend
 
 : staging-command-line ( config -- flags )
     [
-        "-i=" boot-image-name append ,
+        "-i=" my-boot-image-name append ,
 
         "-output-image=" over staging-image-name append ,
 

extra/webapps/fjsc/fjsc.factor

@@ -25,7 +25,7 @@ IN: webapps.fjsc
 : compile-url ( url -- )
   #! Compile the factor code at the given url, return the javascript.
   dup "http:" head? [ "Unable to access remote sites." throw ] when
-  "http://" "Host" header-param rot 3append http-get 2nip compile "();" write flush ;
+  "http://" "Host" header-param rot 3append http-get compile "();" write flush ;
 
 \ compile-url {
   { "url" v-required }

extra/yahoo/yahoo.factor

@@ -26,6 +26,4 @@ C: <result> result
     ] "" make ;
 
 : search-yahoo ( search num -- seq )
-    query http-get 2nip
-    [ "Search failed" throw ] unless*
-    string>xml parse-yahoo ;
+    query http-get string>xml parse-yahoo ;