From 6187a1e5e14978eec4a87e8f2ab094b20a9a8e0b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 17:55:31 -0600 Subject: [PATCH] Improved http.client, bootstrap.image.{download,upload} --- core/bootstrap/image/image.factor | 34 ++++++++++++------- extra/benchmark/bootstrap2/bootstrap2.factor | 4 +-- extra/bootstrap/image/download/authors.txt | 1 + .../bootstrap/image/download/download.factor | 25 ++++++++++++++ extra/bootstrap/image/download/summary.txt | 1 + extra/bootstrap/image/upload/authors.txt | 1 + extra/bootstrap/image/upload/summary.txt | 1 + extra/bootstrap/image/upload/upload.factor | 25 ++++++++++++++ extra/crypto/sha1/sha1.factor | 11 +++--- extra/http/client/client.factor | 27 +++++++-------- extra/io/server/server.factor | 3 +- extra/rss/rss.factor | 2 +- extra/tools/deploy/backend/backend.factor | 7 ++-- extra/webapps/fjsc/fjsc.factor | 2 +- extra/yahoo/yahoo.factor | 4 +-- 15 files changed, 102 insertions(+), 46 deletions(-) create mode 100644 extra/bootstrap/image/download/authors.txt create mode 100644 extra/bootstrap/image/download/download.factor create mode 100644 extra/bootstrap/image/download/summary.txt create mode 100644 extra/bootstrap/image/upload/authors.txt create mode 100644 extra/bootstrap/image/upload/summary.txt create mode 100644 extra/bootstrap/image/upload/upload.factor diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 3dadee5193..7452e31cf8 100755 --- a/core/bootstrap/image/image.factor +++ b/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" + } ; + 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 [ (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 ; diff --git a/extra/benchmark/bootstrap2/bootstrap2.factor b/extra/benchmark/bootstrap2/bootstrap2.factor index bde92a2260..54bc73f4a1 100755 --- a/extra/benchmark/bootstrap2/bootstrap2.factor +++ b/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 ; diff --git a/extra/bootstrap/image/download/authors.txt b/extra/bootstrap/image/download/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/bootstrap/image/download/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/bootstrap/image/download/download.factor b/extra/bootstrap/image/download/download.factor new file mode 100644 index 0000000000..deed045221 --- /dev/null +++ b/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 ; diff --git a/extra/bootstrap/image/download/summary.txt b/extra/bootstrap/image/download/summary.txt new file mode 100644 index 0000000000..fc0ed97ff1 --- /dev/null +++ b/extra/bootstrap/image/download/summary.txt @@ -0,0 +1 @@ +Smart image downloader utility which first checks MD5 checksum diff --git a/extra/bootstrap/image/upload/authors.txt b/extra/bootstrap/image/upload/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/bootstrap/image/upload/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/bootstrap/image/upload/summary.txt b/extra/bootstrap/image/upload/summary.txt new file mode 100644 index 0000000000..85497270a2 --- /dev/null +++ b/extra/bootstrap/image/upload/summary.txt @@ -0,0 +1 @@ +Image upload utility diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor new file mode 100644 index 0000000000..a9f5d1dcd4 --- /dev/null +++ b/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 diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index 94a51288bb..f6dfbcd031 100644 --- a/extra/crypto/sha1/sha1.factor +++ b/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 diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 8e6d8257a4..109bf17c40 100755 --- a/extra/http/client/client.factor +++ b/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 [ [ [ 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> stream-copy - ] [ - r> drop dispose "HTTP download failed" throw - ] if ; + >r http-get-stream check-response + r> stream-copy ; : download ( url -- ) dup download-name download-to ; diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 829da27f6e..a23984c207 100755 --- a/extra/io/server/server.factor +++ b/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 -- ) diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor index be2f648189..0591c60014 100644 --- a/extra/rss/rss.factor +++ b/extra/rss/rss.factor @@ -78,7 +78,7 @@ C: 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 diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 95d19712c0..c295f6369d 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/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 , diff --git a/extra/webapps/fjsc/fjsc.factor b/extra/webapps/fjsc/fjsc.factor index 19dab4ed1b..55609c72f9 100755 --- a/extra/webapps/fjsc/fjsc.factor +++ b/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 } diff --git a/extra/yahoo/yahoo.factor b/extra/yahoo/yahoo.factor index 2c982306cd..1725c10a44 100644 --- a/extra/yahoo/yahoo.factor +++ b/extra/yahoo/yahoo.factor @@ -26,6 +26,4 @@ C: 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 ;