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