From ab03251a6c9a476753c5498ba3a75009c37db272 Mon Sep 17 00:00:00 2001
From: NalaGinrut <address@hidden>
Date: Thu, 23 Feb 2012 17:46:56 +0800
Subject: [PATCH] add some useful procedures for http client

---
 module/web/client.scm |   72 ++++++++++++++++++++++++++++++++++++++++++++++++-
 1 files changed, 71 insertions(+), 1 deletions(-)

diff --git a/module/web/client.scm b/module/web/client.scm
index b035668..fc96284 100644
--- a/module/web/client.scm
+++ b/module/web/client.scm
@@ -37,9 +37,18 @@
   #:use-module (ice-9 rdelim)
   #:use-module (web request)
   #:use-module (web response)
+  #:use-module (web http)
   #:use-module (web uri)
+  #:autoload (rnrs io ports) (get-string-all)
   #:export (open-socket-for-uri
-            http-get))
+            http-get
+            http-get-uri-head
+            http-client-get-block-from-uri
+            http-client-get-check-string
+            http-client-checkout-etag
+            http-client-remove-check-file
+            http-client-etag-stamp
+            http-client-get-ready-to-continue))
 
 (define (open-socket-for-uri uri)
   (let* ((ai (car (getaddrinfo (uri-host uri)
@@ -114,3 +123,64 @@
               (if decode-body?
                   (decode-response-body res body)
                   body)))))
+
+(define* (http-get-uri-head uri #:key (sock (open-socket-for-uri uri)))
+  (let ((rq (build-request uri #:method 'HEAD)))
+    (write-request rq sock)
+    (force-output sock)
+    (let ((head (read-response sock)))
+      (close sock)
+      head)))
+
+(define* (http-client-get-block-from-uri uri #:key (block #f) (start 0) 
+					 (head (http-get-uri-head uri)))
+  (let* ((s (open-socket-for-uri uri))
+	 (end (if block (+ start block) (response-content-length head)))
+	 (range-str (format #f "bytes=~a-~a" start end)) 
+	 (range (parse-header 'range range-str))
+	 (rq (build-request uri #:headers `((range ,@range)))))
+    (write-request rq s)
+    (force-output s)
+    (read-response-body (read-response s))))
+
+(define (http-client-get-check-string path)
+  (let ((target (string-append path ".etag")))
+    (if (file-exists? target)
+	(call-with-input-file target
+	  (lambda (port)
+	    (get-string-all port)))
+	"")))
+
+(define* (http-client-checkout-etag uri #:key (path (uri-path uri)) 
+			(head (http-get-uri-head uri)))
+  (let* ((etag (car (response-etag head)))
+	 (chk-str (http-client-get-check-string path))
+	 )
+    (string=? etag chk-str))) ;; checkout ETag
+
+(define* (http-client-remove-check-file path #:key (ext ".etag"))
+  (let ((chk-file (string-append path ext)))
+    (and (file-exists? chk-file) (delete-file chk-file))))
+
+(define* (http-client-etag-stamp uri #:key (head (http-get-uri-head uri))
+				 (path (uri-path uri))
+				 (ext ".etag"))
+  (let ((chk-file (string-append path ext))
+	(etag (car (response-etag head))))
+    (and (file-exists? chk-file) (delete-file chk-file))
+    (call-with-output-file chk-file
+      (lambda (port)
+	(format port "~a" etag)
+	(close port)))))
+
+(define* (http-client-get-ready-to-continue uri #:key (path (uri-path uri))
+				     (head (http-get-uri-head uri)))
+  (if (http-client-checkout-etag uri #:path path #:head head) ;; checkout ETag
+      (let* ((fp (open-file path "a"))
+	     (pos (stat:size (stat path))))
+	(seek fp pos SEEK_SET)
+	(http-client-remove-check-file path)
+	(values pos fp))
+      (let* ((fp (open-file path "w"))
+	     (pos 0))
+	(values pos fp))))
-- 
1.7.0.4