Merge pull request #14 from chclock/master

修改web相关

Author: evilbinary

apps/web-demo.ss

@@ -1,15 +1,14 @@
 (import (web libra))
 
 (get! "/"
-	 (lambda (p) (view "../apps/index.html")))
+	 (lambda (p) (default-make-response "GET request")))
 
 (post! "/" 
 	(lambda (p) (default-make-response "POST request")))
 
 (get! "/blog/:user/:age" 
 	(lambda (p)
-		(define content (string-append "p是储存所有参数(路由/get请求)的hashtable\n" "User " (hashtable-ref p "user" "") ";Ages " (hashtable-ref p "age" "")))
-		(hashtable-set! p "content" content)
-		(default-make-json p)))
+		(define content (string-append "p是储存所有参数(路由/请求)的关联表; " "User: " (params-ref p "user" "") ",Ages: " (params-ref p "age" "")))
+		(default-make-json (cons (cons "content" content) p))))
 
 (run 8080)

apps/web/app.ss

@@ -7,14 +7,14 @@
 
 (get! "/"
 	 (lambda (p) 
-	 	(if (and (hashtable-contains? p "id") (hashtable-contains? p "page"))
-		 	(id/page->load (hashtable-ref p "id" "0") (hashtable-ref p "page" "-1") (get-option "app-path")))
+	 	(if (and (params-ref p "id") (params-ref p "page"))
+		 	(id/page->load (params-ref p "id") (params-ref p "page") (get-option "app-path")))
 	 	(view "index")))
 
 (get! "/spider" 
 	(lambda (p)
-		(define url (hashtable-ref p "key" "http://www.mm131.com/xinggan"))
-		(define type (hashtable-ref p "type" "xinggan"))
+		(define url (params-ref p "key" "http://www.mm131.com/xinggan"))
+		(define type (params-ref p "type" "xinggan"))
 		(if (eq? #f (string-index url #\_))
 			(set! url (string-append url "/")))
 		(default-make-json (url->id/page url type (get-option "app-path")))))

apps/web/spider.ss

@@ -1,52 +1,57 @@
 (import (net curl)
-		(regex regex)
+		(irregex irregex)
 		(sqlite sqlite))
 
 ;; 获取图片列表html
 (define (get-images-html html)
-	(define pattern "<(dl*)\\b[^>]*>(.*?)</dl>")
-	(define rst (regex-match pattern html))
-	(if (null? rst)
+	(define pattern "dl[\\s\\S]*?dl")
+	(define match (irregex-search pattern html))
+	(if match
+		(substring html (vector-ref match 4) (vector-ref match 6))
 		""
-		(car rst))
+	)
 )
 
 ;; 获取id列表
 (define (html->ids html)
-	(define pattern "<dd><a target.+?www.mm131.com/\\w+?/(\\d+?).html\">[^>]+?>(.+?)</a>")
-	(define rst (regex-matches pattern html))
+	(define pattern "<img.+?pic.(\\d+?)...jpg")
+	(define len (string-length html))
 	(define ids '())
-	(map (lambda (lst)
-			(set! ids (cons (cadr lst) ids))) 
-		rst)
+	(let loop ([match (irregex-search pattern html 0 len)])
+		(when match
+			(set! ids (cons (substring html (vector-ref match 8) (vector-ref match 10)) ids))
+			(loop (irregex-search pattern html (vector-ref match 6)))
+		)
+	)
 	(reverse ids)
 )
 
 ;; 获取一组图片数目
 (define (get-max-page html)
-	(define pattern "<span class=\"page-ch\">.+?(\\d+).+?</span>")
-	(define rst (regex-match pattern html))
-	(if (null? rst)
-		0
-		(string->number (cadr rst)))
+	(define pattern "page-ch[^\\d]+?(\\d*?)[^\\d]+?span")
+	(define match (irregex-search pattern html))
+	(if match
+		(string->number (substring html (vector-ref match 8) (vector-ref match 10)))
+		0)
 )
 
 ;; 获取某id图片页码
 (define (id->page id type path)
 	(define rst (sqlite-exec (string-append "select * from ImageInfo where id=" id)))
 	(define max-page (if (null? rst) 0 (string->number (cadr (car rst)))))
-	(display id)
 	(if (= max-page 0)
 		(begin
 			(set! max-page (get-max-page (url->html (string-append "http://www.mm131.com/" type "/" id ".html"))))
-			(if (not (file-exists? (string-append path "/content/images/mm/" id "-1.jpg")))
-				(url->file 
-					(string-append "http://img1.mm131.com/pic/" id "/1.jpg")
-					(string-append path "/content/images/mm/" id "-1.jpg")))
 			(if (> max-page 0)
 				(sqlite-exec (string-append "INSERT INTO ImageInfo VALUES (" id "," (number->string max-page) ");")))
 		)
 	)
+	(unless (file-exists? (string-append path "/content/images/mm/" id "-1.jpg"))
+		(url->file 
+			(string-append "http://img1.mm131.me/pic/" id "/1.jpg")
+			(string-append path "/content/images/mm/" id "-1.jpg")))
+	(display (string-append "http://img1.mm131.me/pic/" id "/1.jpg"))
+	(newline)
     max-page
 )
 
@@ -74,7 +79,7 @@
 			(begin
 				(if (not (file-exists? file-path))
 					(url->file 
-						(string-append "http://img1.mm131.com/pic/" id "/" (number->string index) ".jpg")
+						(string-append "http://img1.mm131.me/pic/" id "/" (number->string index) ".jpg")
 						file-path))
 				(loop (+ 1 index) (string-append path "/content/images/mm/" id "-" (number->string (+ 1 index)) ".jpg"))
 			)

packages/irregex/README

@@ -0,0 +1,14 @@
+
+                               irregex
+                               -------
+
+               Portable Efficient IrRegular Expressions
+
+                 http://synthcode.com/scheme/irregex/
+
+A fully portable and efficient R[4567]RS implementation of regular
+expressions, supporting both POSIX syntax with various (irregular)
+PCRE extensions, as well as SCSH's SRE syntax.  DFA matching is used
+when possible, otherwise a closure-compiled NFA approach is used.
+
+Documentation is in the file irregex.html.

packages/irregex/irregex-utils.scm

@@ -0,0 +1,154 @@
+;;;; irregex-utils.scm
+;;
+;; Copyright (c) 2010 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define rx-special-chars
+  "\\|[](){}.*+?^$#")
+
+(define (string-scan-char str c . o)
+  (let ((end (string-length str)))
+    (let scan ((i (if (pair? o) (car o) 0)))
+      (cond ((= i end) #f)
+            ((eqv? c (string-ref str i)) i)
+            (else (scan (+ i 1)))))))
+
+(define (irregex-quote str)
+  (list->string
+   (let loop ((ls (string->list str)) (res '()))
+     (if (null? ls)
+         (reverse res)
+         (let ((c (car ls)))
+           (if (string-scan-char rx-special-chars c)
+               (loop (cdr ls) (cons c (cons #\\ res)))
+               (loop (cdr ls) (cons c res))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (irregex-opt ls)
+  (define (make-alt ls)
+    (cond ((null? (cdr ls)) (car ls))
+          ((every char? ls) (list (list->string ls)))
+          (else (cons 'or ls))))
+  (define (make-seq ls)
+    (cond ((null? (cdr ls)) (car ls))
+          ((every (lambda (x) (or (string? x) (char? x))) ls)
+           (apply string-append (map (lambda (x) (if (char? x) (string x) x)) ls)))
+          (else (cons 'seq ls))))
+  (cond
+   ((null? ls) "")
+   ((null? (cdr ls)) (car ls))
+   (else
+    (let ((chars (make-vector 256 '())))
+      (let lp1 ((ls ls) (empty? #f))
+        (if (null? ls)
+            (let lp2 ((i 0) (res '()))
+              (if (= i 256)
+                  (let ((res (make-alt (reverse res))))
+                    (if empty? `(? ,res) res))
+                  (let ((c (integer->char i))
+                        (opts (vector-ref chars i)))
+                    (lp2 (+ i 1)
+                         (cond
+                          ((null? opts) res)
+                          ((equal? opts '("")) `(,c ,@res))
+                          (else `(,(make-seq (list c (irregex-opt opts)))
+                                  ,@res)))))))
+            (let* ((str (car ls))
+                   (len (string-length str)))
+              (if (zero? len)
+                  (lp1 (cdr ls) #t)
+                  (let ((i (char->integer (string-ref str 0))))
+                    (vector-set!
+                     chars
+                     i
+                     (cons (substring str 1 len) (vector-ref chars i)))
+                    (lp1 (cdr ls) empty?))))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (cset->string ls)
+  (let ((out (open-output-string)))
+    (let lp ((ls ls))
+      (cond
+       ((pair? ls)
+        (cond
+         ((pair? (car ls))
+          (display (irregex-quote (string (caar ls))) out)
+          (write-char #\- out)
+          (display (irregex-quote (string (cdar ls))) out))
+         (else (display (irregex-quote (string (car ls))) out)))
+        (lp (cdr ls)))))
+    (get-output-string out)))
+
+(define (sre->string obj)
+  (let ((out (open-output-string)))
+    (let lp ((x obj))
+      (cond
+       ((pair? x)
+        (case (car x)
+          ((: seq)
+           (cond
+            ((and (pair? (cdr x)) (pair? (cddr x)) (not (eq? x obj)))
+             (display "(?:" out) (for-each lp (cdr x)) (display ")" out))
+            (else (for-each lp (cdr x)))))
+          ((submatch)
+           (display "(" out) (for-each lp (cdr x)) (display ")" out))
+          ((submatch-named)
+           (display "(?<" out) (display (cadr x) out) (display ">" out)
+           (for-each lp (cddr x)) (display ")" out))
+          ((or)
+           (display "(?:" out)
+           (lp (cadr x))
+           (for-each (lambda (x) (display "|" out) (lp x)) (cddr x))
+           (display ")" out))
+          ((* + ? *? ??)
+           (cond
+            ((pair? (cddr x))
+             (display "(?:" out) (for-each lp (cdr x)) (display ")" out))
+            (else (lp (cadr x))))
+           (display (car x) out))
+          ((not)
+           (cond
+            ((and (pair? (cadr x)) (eq? 'cset (caadr x)))
+             (display "[^" out)
+             (display (cset->string (cdadr x)) out)
+             (display "]" out))
+            (else (error "can't represent general 'not' in strings" x))))
+          ((cset)
+           (display "[" out)
+           (display (cset->string (cdr x)) out)
+           (display "]" out))
+          ((- & / ~)
+           (cond
+            ((or (eq? #\~ (car x))
+                 (and (eq? '- (car x)) (pair? (cdr x)) (eq? 'any (cadr x))))
+             (display "[^" out)
+             (display (cset->string (if (eq? #\~ (car x)) (cdr x) (cddr x))) out)
+             (display "]" out))
+            (else
+             (lp `(cset ,@(sre->cset x))))))
+          ((w/case w/nocase)
+           (display "(?" out)
+           (if (eq? (car x) 'w/case) (display "-" out))
+           (display ":" out)
+           (for-each lp (cdr x))
+           (display ")" out))
+          (else
+           (if (string? (car x))
+               (lp `(cset ,@(string->list (car x))))
+               (error "unknown sre operator" x)))))
+       ((symbol? x)
+        (case x
+          ((bos bol) (display "^" out))
+          ((eos eol) (display "$" out))
+          ((any nonl) (display "." out))
+          (else (error "unknown sre symbol" x))))
+       ((string? x)
+        (display (irregex-quote x) out))
+       ((char? x)
+        (display (irregex-quote (string x)) out))
+       (else
+        (error "unknown sre pattern" x))))
+    (get-output-string out)))
+