@@ 15,15 15,14 @@ define : help-message args
tests
test-assert : string-contains (help-message '("./program")) "./program"
test-equal #\U : string-ref (help-message '("./program")) 0
- format #f "Usage: ~a [DOWNLOAD_URL | --serve FOLDER] [options]
+ format #f "Usage: ~a [--serve FOLDER] [options] [DOWNLOAD_LINK]
Options:
- [link [link ...]] download file(s)
- --ip <ip> set server IP (default: [::])
- --port <port> set server port (default: 8083)
- --lazy hash served when they are requested instead of at startup (default: #f)
- --help show this message
- --test run unit tests
+ --ip <ip> set server IP (default: [::])
+ --port <port> set server port (default: 8083)
+ --output <filename> set output filename for DOWNLOAD_LINK
+ --lazy hash served when they are requested instead of at startup (default: #f)
+ --help show this message
" : first args
define : help args
@@ 34,32 33,29 @@ define : opt-member arguments opt
let : : op : member opt arguments
if : or (not op) : > 2 : length op
. #f
- . op
+ take op 2
define : main args
let : : arguments : cdr args
cond
: or (null? arguments) (member "--help" arguments) (member "-h" arguments)
help args
- : and {(length arguments) > 1} : equal? "--serve" : first arguments
- let
- : ip-opt : or (opt-member arguments "--ip") '("--ip" "::")
+ else
+ ;; : and {(length arguments) > 1} : equal? "--serve" : first arguments
+ let*
+ : serve-opt : or (opt-member arguments "--serve") '("--serve" #f)
+ ip-opt : or (opt-member arguments "--ip") '("--ip" "::")
port-opt : or (opt-member arguments "--port") '("--port" "8083")
lazy : member "--lazy" arguments
- serve (second arguments) (second ip-opt) (string->number (second port-opt)) (not lazy)
- else
- let*
- : download-data : download-file : car arguments
- output-opt : opt-member arguments "--output"
- output-file
- if output-opt
- second output-opt
- first
- take-right : split-and-decode-uri-path : uri-path : string->uri : car arguments
- . 1
- port : open-output-file output-file
- put-bytevector port download-data
- close-port port
+ output-opt : or (opt-member arguments "--output") '("--output" #f)
+ positional-arguments : lset-difference equal? arguments serve-opt ip-opt port-opt output-opt '("--lazy")
+ cond
+ : and (second serve-opt) (null? positional-arguments)
+ serve (second serve-opt) (second ip-opt) (string->number (second port-opt)) (not lazy)
+ : second serve-opt
+ serve-and-download (second serve-opt) (second ip-opt) (string->number (second port-opt)) (not lazy) (first positional-arguments) (second output-opt)
+ else
+ download-file-to-disk (first positional-arguments) : second output-opt
@@ 32,7 32,7 @@ define-module : wispserve serve
;; http://rfc-gnutella.sourceforge.net/src/Partial_File_Sharing_Protocol_1.0.txt
define-module : wispserve serve
- . #:export : serve download-file
+ . #:export : serve download-file serve-and-download download-file-to-disk
import
only (srfi srfi-27) random-source-make-integers
@@ 52,6 52,8 @@ import
ice-9 pretty-print
ice-9 binary-ports
prefix (fibers web server) fibers: ;; using fibers, mind the different arguments of run-server!
+ prefix (fibers channels) fibers:
+ prefix (fibers) fibers:
web server ;; standard Guile server, mind the different arguments of run-server!
web client
web request
@@ 63,32 65,36 @@ import
only (ice-9 vlist) alist->vhash vhash-cons vhash-assoc vhash-fold vlist->list vhash-delete
only (web http) declare-opaque-header!
only (oop goops) define-generic define-method <string>
- only (rnrs bytevectors) bytevector-length utf8->string bytevector->u8-list u8-list->bytevector bytevector-copy! make-bytevector
+ only (rnrs bytevectors) bytevector-length utf8->string string->utf8 bytevector->u8-list u8-list->bytevector bytevector-copy! make-bytevector
only (srfi srfi-27) random-integer
only (ice-9 textual-ports) put-string
+ only (ice-9 atomic) atomic-box-set! atomic-box-ref atomic-box-compare-and-swap! make-atomic-box atomic-box-swap!
+ only (ice-9 suspendable-ports) install-suspendable-ports!
-define : run-ipv4-fibers-server handler-with-path ip
- fibers:run-server handler-with-path #:family AF_INET #:port 8083 #:addr INADDR_ANY
+install-suspendable-ports!
-define : run-ipv6-fibers-server handler-with-path ip
+define : run-ipv4-fibers-server handler-with-path ip port
+ fibers:run-server handler-with-path #:family AF_INET #:port port #:addr INADDR_ANY
+
+define : run-ipv6-fibers-server handler-with-path ip port
define s
let : : s : socket AF_INET6 SOCK_STREAM 0
setsockopt s SOL_SOCKET SO_REUSEADDR 1
- bind s AF_INET6 (inet-pton AF_INET6 ip) 8083
+ bind s AF_INET6 (inet-pton AF_INET6 ip) port
. s
- fibers:run-server handler-with-path #:family AF_INET6 #:port 8083 #:addr (inet-pton AF_INET6 ip) #:socket s
+ fibers:run-server handler-with-path #:family AF_INET6 #:port port #:addr (inet-pton AF_INET6 ip) #:socket s
-define : run-ipv4-standard-server handler-with-path ip
- run-server handler-with-path 'http `(#:host "localhost" #:family ,AF_INET #:addr ,INADDR_ANY #:port 8083)
+define : run-ipv4-standard-server handler-with-path ip port
+ run-server handler-with-path 'http `(#:host "localhost" #:family ,AF_INET #:addr ,INADDR_ANY #:port ,port)
-define : run-ipv6-standard-server handler-with-path ip
+define : run-ipv6-standard-server handler-with-path ip port
define s
let : : s : socket AF_INET6 SOCK_STREAM 0
setsockopt s SOL_SOCKET SO_REUSEADDR 1
- bind s AF_INET6 (inet-pton AF_INET6 ip) 8083
+ bind s AF_INET6 (inet-pton AF_INET6 ip) port
. s
- run-server handler-with-path 'http `(#:family ,AF_INET6 #:addr (inet-pton AF_INET6 ip) #:port 8083 #:socket ,s)
+ run-server handler-with-path 'http `(#:family ,AF_INET6 #:addr (inet-pton AF_INET6 ip) #:port ,port #:socket ,s)
define-record-type <served>
served serverpath accesspath size mimetype sha256
@@ 159,9 165,6 @@ define : range-end-< a b
define : merge-ranges received-ranges
;; TODO: Add ranges that can have offsets, so bytevectors can be shared.
- ;; FIXME: this is currently too slow. First calculate the
- ;; resulting ranges with source-ranges, then create new
- ;; bytevectors and fill them without intermediate steps.
. "merge ranges in RECEIVED-RANGES into a new list, ordered with the range with the highest start first."
let loop : (merged '()) (original (sort received-ranges range-start->))
cond
@@ 308,6 311,44 @@ define : missing-ranges-bytes size recei
: and {received-end < next-end} {received-start > next-start}
loop (cons (cons next-start received-start) missing) (cons (cons received-end next-end) (cdr to-check)) received-by-start
+
+define : download-file-to-disk url filename
+ define output-filename
+ or filename
+ first
+ take-right : split-and-decode-uri-path : uri-path : string->uri url
+ . 1
+ define port : open-output-file output-filename
+ define data : download-file url
+ if : string? data
+ put-bytevector port : string->utf8 data
+ put-bytevector port data
+ close-port port
+ format #t "Downloaded url ~a to ~a\n" url output-filename
+
+define : get-resp-content-range resp-headers
+ . "get content-range headers and parse if necessary"
+ ;; FIXME: find out why content-range cannot be parsed correctly when download-file is called from a fiber.
+ define content-range : assoc 'content-range resp-headers
+ cond
+ : not content-range
+ . content-range
+ : pair? : cdr content-range
+ . content-range ;; parsed successfully
+ : string? : cdr content-range
+ let*
+ : bytes-and-rest : string-split (cdr content-range) #\space
+ range-and-size : string-split (second bytes-and-rest) #\/
+ start-stop : map string->number : string-split (first range-and-size) #\-
+ start : first start-stop
+ stop : if (cdr start-stop) (second start-stop) #f
+ cons (car content-range)
+ ` ,(string->symbol (first bytes-and-rest)) ,(cons start stop) ,(string->number (second range-and-size))
+ else
+ error "unsupported content-range: content-range header must be pair or string, but it is:"
+ cdr content-range
+
+
define : download-file url
let loop : (size #f) (received-ranges '())
define missing-ranges
@@ 330,10 371,10 @@ define : download-file url
pretty-print headers
let-values : : (resp body) : http-get uri #:headers headers
define resp-headers : response-headers resp
- define content-range : assoc 'content-range resp-headers
+ define content-range : get-resp-content-range resp-headers
;; pretty-print size
;; pretty-print resp
- pretty-print resp-headers
+ ;; pretty-print resp-headers
;; pretty-print content-range
;; pretty-print : if (string? body) body : bytevector->string body "ISO-8859-1"
cond
@@ 775,7 816,32 @@ define : serve folder-path ip port hash-
. ip
. port
if : string-contains ip ":"
- run-ipv6-fibers-server handler-with-path ip
- run-ipv4-fibers-server handler-with-path ip
- ;; run-ipv6-standard-server handler-with-path ip
- ;; run-ipv4-standard-server handler-with-path ip
+ run-ipv6-fibers-server handler-with-path ip port
+ run-ipv4-fibers-server handler-with-path ip port
+ ;; run-ipv6-standard-server handler-with-path ip port
+ ;; run-ipv4-standard-server handler-with-path ip port
+
+
+define next-download
+ make-atomic-box #f
+
+define : serve-and-download folder-path ip port hash-eagerly url output-filename
+ define done-channel : fibers:make-channel
+ fibers:run-fibers
+ λ _
+ fibers:spawn-fiber
+ λ _
+ download-file-to-disk url output-filename
+ fibers:put-message done-channel 'done
+ ;; fibers:spawn-fiber
+ ;; λ _
+ ;; while #t
+ ;; let : : url : atomic-box-swap! next-download #f
+ ;; if url
+ ;; fibers:spawn-fiber : λ _ : download-file url
+ ;; usleep 10000
+ ;; FIXME: must sleep for a bit to allow the download-fiber to start because for some reason the server blocks the download-fiber from starting.
+ fibers:spawn-fiber : λ _ : serve folder-path ip port hash-eagerly
+ ;; wait until the download is done.
+ fibers:get-message done-channel
+