implement servent mode: serve-and-download
2 files changed, 108 insertions(+), 46 deletions(-)

M run-wispserve.w
M wispserve/serve.w
M run-wispserve.w +21 -25
@@ 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
              
   
 

          
M wispserve/serve.w +87 -21
@@ 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
+