Fixes, rename sliding-groups to clumps
parent
ebb0093ab1
commit
9d5d4ec5c4
|
@ -60,10 +60,12 @@ SYMBOL: error-stream
|
|||
[ with-output-stream* ] curry with-disposal ; inline
|
||||
|
||||
: with-streams* ( input output quot -- )
|
||||
[ with-input-stream* ] curry with-output-stream* ; inline
|
||||
[ output-stream set input-stream set ] prepose with-scope ; inline
|
||||
|
||||
: with-streams ( input output quot -- )
|
||||
[ with-input-stream ] curry with-output-stream ; inline
|
||||
[ [ with-streams* ] 3curry ]
|
||||
[ [ drop dispose dispose ] 3curry ] 3bi
|
||||
[ ] cleanup ; inline
|
||||
|
||||
: tabular-output ( style quot -- )
|
||||
swap >r { } make r> output-stream get stream-write-table ; inline
|
||||
|
|
|
@ -42,29 +42,31 @@ TUPLE: sliced-groups < groups ;
|
|||
|
||||
M: sliced-groups nth group@ <slice> ;
|
||||
|
||||
TUPLE: sliding-groups < abstract-groups ;
|
||||
TUPLE: clumps < abstract-groups ;
|
||||
|
||||
: <sliding-groups> ( seq n -- groups )
|
||||
sliding-groups construct-groups ; inline
|
||||
: <clumps> ( seq n -- groups )
|
||||
clumps construct-groups ; inline
|
||||
|
||||
M: sliding-groups length
|
||||
M: clumps length
|
||||
[ seq>> length ] [ n>> ] bi - 1+ ;
|
||||
|
||||
M: sliding-groups set-length
|
||||
M: clumps set-length
|
||||
[ n>> + 1- ] [ seq>> ] bi set-length ;
|
||||
|
||||
M: sliding-groups group@
|
||||
M: clumps group@
|
||||
[ n>> over + ] [ seq>> ] bi ;
|
||||
|
||||
TUPLE: sliced-sliding-groups < groups ;
|
||||
TUPLE: sliced-clumps < groups ;
|
||||
|
||||
: <sliced-sliding-groups> ( seq n -- groups )
|
||||
sliced-sliding-groups construct-groups ; inline
|
||||
: <sliced-clumps> ( seq n -- groups )
|
||||
sliced-clumps construct-groups ; inline
|
||||
|
||||
M: sliced-sliding-groups nth group@ <slice> ;
|
||||
M: sliced-clumps nth group@ <slice> ;
|
||||
|
||||
: group ( seq n -- array ) <groups> { } like ;
|
||||
|
||||
: clump ( seq n -- array ) <clumps> { } like ;
|
||||
|
||||
: ?head ( seq begin -- newseq ? )
|
||||
2dup head? [ length tail t ] [ drop f ] if ;
|
||||
|
||||
|
|
|
@ -16,7 +16,7 @@ IN: builder.util
|
|||
|
||||
: minutes>ms ( min -- ms ) 60 * 1000 * ;
|
||||
|
||||
: file>string ( file -- string ) utf8 [ stdio get contents ] with-file-reader ;
|
||||
: file>string ( file -- string ) utf8 file-contents ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
@ -107,5 +107,5 @@ USE: prettyprint
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: git-id ( -- id )
|
||||
{ "git" "show" } utf8 <process-stream> [ readln ] with-stream
|
||||
{ "git" "show" } utf8 <process-reader> [ readln ] with-input-stream
|
||||
" " split second ;
|
||||
|
|
|
@ -27,74 +27,56 @@ DEFER: http-request
|
|||
: store-path ( request path -- request )
|
||||
"?" split1 >r >>path r> dup [ query>assoc ] when >>query ;
|
||||
|
||||
: request-with-url ( url request -- request )
|
||||
swap parse-url >r >r store-path r> >>host r> >>port ;
|
||||
|
||||
! 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 ;
|
||||
|
||||
: relative-redirect ( path -- request )
|
||||
request get swap store-path ;
|
||||
: request-with-url ( request url -- request )
|
||||
parse-url >r >r store-path r> >>host r> >>port ;
|
||||
|
||||
SYMBOL: redirects
|
||||
|
||||
: absolute-url? ( url -- ? )
|
||||
[ "http://" head? ] [ "https://" head? ] bi or ;
|
||||
|
||||
: do-redirect ( response -- response stream )
|
||||
dup response-code 300 399 between? [
|
||||
output-stream get dispose
|
||||
: do-redirect ( response data -- response data )
|
||||
over code>> 300 399 between? [
|
||||
drop
|
||||
redirects inc
|
||||
redirects get max-redirects < [
|
||||
header>> "location" swap at
|
||||
dup absolute-url? [
|
||||
absolute-redirect
|
||||
] [
|
||||
relative-redirect
|
||||
] if "GET" >>method http-request
|
||||
request get
|
||||
swap "location" header dup absolute-url?
|
||||
[ request-with-url ] [ store-path ] if
|
||||
"GET" >>method http-request
|
||||
] [
|
||||
too-many-redirects
|
||||
] if
|
||||
] [
|
||||
output-stream get
|
||||
] if ;
|
||||
|
||||
: close-on-error ( stream quot -- )
|
||||
'[ , with-stream* ] [ ] pick '[ , dispose ] cleanup ; inline
|
||||
] when ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: http-request ( request -- response stream )
|
||||
dup request [
|
||||
dup request-addr latin1 <client>
|
||||
[
|
||||
1 minutes timeouts
|
||||
write-request
|
||||
input-stream get dispose
|
||||
read-response
|
||||
do-redirect
|
||||
] close-on-error
|
||||
] with-variable ;
|
||||
|
||||
: read-chunks ( -- )
|
||||
read-crlf ";" split1 drop hex> dup { f 0 } member?
|
||||
[ drop ] [ read % read-crlf "" assert= read-chunks ] if ;
|
||||
|
||||
: do-chunked-encoding ( response stream -- response stream/string )
|
||||
over "transfer-encoding" header "chunked" = [
|
||||
[ [ read-chunks ] "" make ] with-input-stream
|
||||
] when ;
|
||||
: read-response-body ( response -- response data )
|
||||
dup "transfer-encoding" header "chunked" =
|
||||
[ [ read-chunks ] "" make ] [ input-stream get contents ] if ;
|
||||
|
||||
: http-request ( request -- response data )
|
||||
dup request [
|
||||
dup request-addr latin1 [
|
||||
1 minutes timeouts
|
||||
write-request
|
||||
read-response
|
||||
read-response-body
|
||||
] with-client
|
||||
do-redirect
|
||||
] with-variable ;
|
||||
|
||||
: <get-request> ( url -- request )
|
||||
<request> request-with-url "GET" >>method ;
|
||||
<request>
|
||||
swap request-with-url
|
||||
"GET" >>method ;
|
||||
|
||||
: string-or-contents ( stream/string -- string )
|
||||
dup string? [ contents ] unless ;
|
||||
|
||||
: http-get-stream ( url -- response stream/string )
|
||||
<get-request> http-request do-chunked-encoding ;
|
||||
: http-get* ( url -- response data )
|
||||
<get-request> http-request ;
|
||||
|
||||
: success? ( code -- ? ) 200 = ;
|
||||
|
||||
|
@ -114,29 +96,24 @@ M: download-failed error.
|
|||
over code>> success? [ nip ] [ download-failed ] if ;
|
||||
|
||||
: http-get ( url -- string )
|
||||
http-get-stream string-or-contents check-response ;
|
||||
http-get* check-response ;
|
||||
|
||||
: download-name ( url -- name )
|
||||
file-name "?" split1 drop "/" ?tail drop ;
|
||||
|
||||
: download-to ( url file -- )
|
||||
#! Downloads the contents of a URL to a file.
|
||||
swap http-get-stream check-response
|
||||
dup string? [
|
||||
latin1 [ write ] with-file-writer
|
||||
] [
|
||||
[ swap latin1 <file-writer> stream-copy ] with-disposal
|
||||
] if ;
|
||||
>r http-get r> latin1 [ write ] with-file-writer ;
|
||||
|
||||
: download ( url -- )
|
||||
dup download-name download-to ;
|
||||
|
||||
: <post-request> ( content-type content url -- request )
|
||||
<request>
|
||||
request-with-url
|
||||
"POST" >>method
|
||||
swap >>post-data
|
||||
swap >>post-data-type ;
|
||||
"POST" >>method
|
||||
swap request-with-url
|
||||
swap >>post-data
|
||||
swap >>post-data-type ;
|
||||
|
||||
: http-post ( content-type content url -- response string )
|
||||
<post-request> http-request do-chunked-encoding string-or-contents ;
|
||||
: http-post ( content-type content url -- response data )
|
||||
<post-request> http-request ;
|
||||
|
|
|
@ -32,7 +32,7 @@ HOOK: (pipe) io-backend ( -- pipe )
|
|||
: <pipes> ( n -- pipes )
|
||||
[ (pipe) dup add-always-destructor ] replicate
|
||||
f f pipe boa [ prefix ] [ suffix ] bi
|
||||
2 <sliding-groups> ;
|
||||
2 <clumps> ;
|
||||
|
||||
: with-pipe-fds ( seq -- results )
|
||||
[
|
||||
|
|
Loading…
Reference in New Issue