It is a reusable module which can be
used in many web application.
,-----------------------------------------------------------------
(provide filtrate-url-encoded-string)
;;; -----------------------------------------------------------------
;;; This module is named `filtrate-url-encoded-string.rkt'.
;;;
;;; According to HTTP, some characters in the request must be encoded
;;; during the transmission, and it is the server's responsibility to
;;; decode them back to the original. These characters include:
;;; %, /, ., .., #, ?, ;, :, $, +, @, &, =, {, }, |, ^, ~, [, ], ', >, <, "
;;;
;;; also, 0x00-0x1F, 0x7F are nonprintable, they are restricted to use.
;;; values in the range >0x7F, charaecters are not the 7-bit ascii set.
;;; -----------------------------------------------------------------
(define filtrate-url-encoded-string
(lambda (str)
(cond
((or (null? str)
(eq? #f str))
(error "input data are invalid."))
((string? str)
(let loop ([c 0]
[newstr ""])
(cond
((= c (string-length str)) newstr)
;; the newline character is encoded to %0A or %0a, but according
;; to HTTP, the newline follows 0d (carriage return) as %0d0a.
;; So, it should not be decoded standalone, instead, it should
;; be encoded with the 0d together, see the code given later.
;;
;;((and (char=? (string-ref str c) #\%)
;; (char=? (string-ref str (+ c 1)) #\0)
;; (char-ci=? (string-ref str (+ c 2)) #\A))
;; (loop (+ c 3)
;; (string-append newstr (string #\newline))))
;;
;; Also, space is encoded as "%20", but usually it is encoded
;; as "+" by browsers. See the code given later.
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\2)
(char=? (string-ref str (+ c 2)) #\0))
(loop (+ c 3)
(string-append newstr (string #\space))
(string-ref str c)))
;; ! (exclamation mark) encoded to %21
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\2)
(char=? (string-ref str (+ c 2)) #\1))
(loop (+ c 3)
(string-append newstr (string #\!))))
;; " (double quotes) encoded to %22
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\2)
(char=? (string-ref str (+ c 2)) #\2))
(loop (+ c 3)
(string-append newstr (string #\"))))
;; # (hash) encoded to %23
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\2)
(char=? (string-ref str (+ c 2)) #\3))
(loop (+ c 3)
(string-append newstr (string #\#))))
;; $ (dollar) encoded to %24
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\2)
(char=? (string-ref str (+ c 2)) #\4))
(loop (+ c 3)
(string-append newstr (string #\$))))
;; % (percent sign) encoded to %25
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\2)
(char=? (string-ref str (+ c 2)) #\5))
(loop (+ c 3)
(string-append newstr (string #\%))))
;; & (ampersand) encoded to %26
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\2)
(char=? (string-ref str (+ c 2)) #\6))
(loop (+ c 3)
(string-append newstr (string #\&))))
;; ' (single quote mark) encoded to %27
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\2)
(char=? (string-ref str (+ c 2)) #\7))
(loop (+ c 3)
(string-append newstr (string #\'))))
;; + (plus sign) encoded to %2b
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\2)
(char-ci=? (string-ref str (+ c 2)) #\B))
(loop (+ c 3)
(string-append newstr (string #\+))))
;; . (dot) encoded to %2e
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\2)
(char-ci=? (string-ref str (+ c 2)) #\E))
;; .. (two dots) encoded to
(loop (+ c 3)
(string-append newstr (string #\.))))
;; / (slash) encoded to %2F or %2f
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\2)
(char-ci=? (string-ref str (+ c 2)) #\F))
(loop (+ c 3)
(string-append newstr (string #\/))))
;; : (colon) encoded to %3A or %3a
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\3)
(char-ci=? (string-ref str (+ c 2)) #\A))
(loop (+ c 3)
(string-append newstr (string #\:))))
;; ; (semicolon) encoded to %3B or %3b
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\3)
(char-ci=? (string-ref str (+ c 2)) #\B))
(loop (+ c 3)
(string-append newstr (string #\;))))
;; < (less than) encoded to %3C
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\3)
(char-ci=? (string-ref str (+ c 2)) #\C))
(loop (+ c 3)
(string-append newstr (string #\<))))
;; = (equal sign) encoded to %3D or %3d
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\3)
(char-ci=? (string-ref str (+ c 2)) #\D))
(loop (+ c 3)
(string-append newstr (string #\=))))
;; = (equal sign) encoded to %3D or %3d
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\3)
(char-ci=? (string-ref str (+ c 2)) #\D))
(loop (+ c 3)
(string-append newstr (string #\=))))
;; > (greater than) encoded to %3E or %3e
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\3)
(char-ci=? (string-ref str (+ c 2)) #\E))
(loop (+ c 3)
(string-append newstr (string #\>))))
;; ? (question mark) encoded to %3F or %3f
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\3)
(char-ci=? (string-ref str (+ c 2)) #\F))
(loop (+ c 3)
(string-append newstr (string #\?))))
;; @ (at sign) encoded to %40
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\4)
(char=? (string-ref str (+ c 2)) #\0))
(loop (+ c 3)
(string-append newstr (string #\@))))
;; [ (left square bracket) encoded %5b
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\5)
(char-ci=? (string-ref str (+ c 2)) #\b))
(loop (+ c 3)
(string-append newstr (string #\[))))
;; \ (backslash) encoded to %5c
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\5)
(char-ci=? (string-ref str (+ c 2)) #\c))
(loop (+ c 3)
(string-append newstr (string #\\))))
;; ] (right square bracket) encoded to %5d
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\5)
(char-ci=? (string-ref str (+ c 2)) #\d))
(loop (+ c 3)
(string-append newstr (string #\]))))
;; ^ (circumflex) encoded to %5e
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\5)
(char-ci=? (string-ref str (+ c 2)) #\e))
(loop (+ c 3)
(string-append newstr (string #\^))))
;; { (left parenthesis) encoded to %7b
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\7)
(char-ci=? (string-ref str (+ c 2)) #\B))
(loop (+ c 3)
(string-append newstr (string #\{))))
;; | encoded to %7c
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\7)
(char-ci=? (string-ref str (+ c 2)) #\C))
(loop (+ c 3)
(string-append newstr (string #\|))))
;; } (right parenthesis)encoded to %7d
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\7)
(char-ci=? (string-ref str (+ c 2)) #\d))
(loop (+ c 3)
(string-append newstr (string #\}))))
;; ~ (tilde) encoded to %7e
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\7)
(char-ci=? (string-ref str (+ c 2)) #\e))
(loop (+ c 3)
(string-append newstr (string #\~))))
;; newline is encoded to %0d0a or %0D0A
((and (char=? (string-ref str c) #\%)
(char=? (string-ref str (+ c 1)) #\0)
(char-ci=? (string-ref str (+ c 2)) #\d)
(char=? (string-ref str (+ c 3)) #\0)
(char-ci=? (string-ref str (+ c 4)) #\a))
(loop (+ c 5)
(string-append newstr (string #\newline))))
;; in the case of "+" occurs.
((char=? (string-ref str c) #\+)
(loop (+ c 1)
(string-append newstr (string #\space))))
;; no encoded character occurs
(else
(loop (+ c 1)
(string-append newstr
(string (string-ref str c)))))))))))
;;; -----------------------------------------------------------------
;;; End.
;;; -----------------------------------------------------------------
/ ----------------------------------------------------------------------------------------------- /
;;; -----------------------------------------------------------------
;;; This is a CGI program named "create-subdir.rkt".
;;;
;;; This Scheme module is used to create a new directory on the web server
;;; according the webmaster's requested data.
;;; -----------------------------------------------------------------
(require "macros-as-toolkit.rkt")
(require "http-post.rkt")
;; alist provided from http-post.rkt module can be used here:
(define alist-we-have alist-of-post-request)
;; From the alist provided from http-post.rkt module, we can find the
;; parent directory, and the name of the sub-directory to create.
(define parent-dir ; a string
(cadr
(assoc "parent-directory" alist-of-post-request)))
(define new-sub-dir ; another string
(cadr
(assoc "sub-directory-name" alist-of-post-request)))
;; When we get the parent directory from the alist, we should use
;; it to locate the current directory. We shall replace the host.domain
;; in the url, if it is supplied, further more, we have to replace
;; the host.domain substring with the web resource root.
(define dir
(cond
;; has the padding slash
((regexp-match? #rx"^http://www.xxxx.com/" parent-dir)
(substring parent-dir
(string-length "httpwww.xxxx.com/")
(string-length parent-dir)))
;; does not have the padding slash
((regexp-match? #rx"^http://www.xxxx.com" parent-dir)
(substring parent-dir
(string-length "http://www.xxxx.com")
(string-length parent-dir)))
;; host.domain is not given, which is fine.
(else
parent-dir)))
;; Checking if the dir has a padding slash here:
(set! dir
(let* ([lst (string->list dir)]
[r-lst (reverse lst)])
(if (char=? (car r-lst) #\/)
(list->string (reverse (cdr r-lst)))
(list->string (reverse r-lst)))))
(define web-resource-root-dir "/xxxx/xxx/www/xxxx/")
(define cur-dir
(string-append
web-resource-root-dir
dir))
;; Now we can set the current directory as the following:
(current-directory cur-dir)
;; Before creating a new directory, let us do some checks:
;;
;; a) if the given new directory name has any collision with the
;; sub-directories which already exist?
;;
;; b) if the given new directory name is legal according to the FreeBSD's
;; file system naming convention?
(define list-of-pathes-under-current-directory
(directory-list (current-directory)))
(define list-path-strings-under-current-directory
(map (lambda (path)
(path->string path))
list-of-pathes-under-current-directory))
(define get-list-of-subdirs
(lambda (list-path-strings-under-current-directory)
(let loop ([subdirs '()]
[l list-path-strings-under-current-directory])
(cond
((null? l) subdirs)
((directory-exists? (car l))
(loop (cons (car l) subdirs)
(cdr l)))
(else
(loop subdirs
(cdr l)))))))
(define list-of-subdirs
(get-list-of-subdirs
list-path-strings-under-current-directory))
;; Name collision checking is made here. First we construct a predicate:
(define name-collision?
(lambda (new-sub-dir list-of-subdirs)
(let loop ([l list-of-subdirs])
(cond
((null? l) #f)
((string=? new-sub-dir (car l)) #t)
(else
(loop (cdr l)))))))
;; We need to have a web page to tell the webmaster directory name
;; collision happened, and ask him to select another directory name
;; which is valid on the web server.
(define-values (html-begin
html-end
form-to-create-a-new-sub-directory)
(values (file->string "html-begin.txt")
(file->string "html-end.txt")
(file->string "form-to-create-a-new-sub-directory.txt")))
(define send-name-collision-err-webpage
(lambda ()
(display "Content-Type: text/html")
(newline)
(newline)
(display html-begin)
(display
(combine (list "<p>"
"Sorry, the provided new directory name already existed on the web server. "
"Please select another directory name."
"</p>")))
(display form-to-create-a-new-sub-directory)
(display html-end)))
;; Directory name collision checking is done here:
(when (name-collision? new-sub-dir list-of-subdirs)
(begin
(send-name-collision-err-webpage)
(error "Sorry, the provided new directory name already existed on the web server.")))
;; Next, make the name validity checking. FreeBSD system is very
;; tolerant to the directory naming, but still there should be some
;; conventions to obey:
;;
;; a) directory should started with an underscore character or
;; alphabetic character;
;;
;; b) slash character is restricted to use, because it is used for
;; the path delimiter;
;;
;; c) dollar sign has special meaning on the server, it should not
;; be used in the name;
;;
;; d) space is allowed, but it should be escaped;
;;
;; e) other exceptions can be listed here later ...
(define start-with-valid-character?
(lambda (new-sub-dir)
(let ([l (string->list new-sub-dir)])
(if (and (char=? (car l) #\_)
(char-alphabetic? (car l))
(char-numeric? (car l))) #t #f))))
(define has-dollar-sign?
(lambda (new-sub-dir)
(let ([l (string->list new-sub-dir)])
(let loop ([lst l])
(cond
((null? lst) #f)
((char=? (car lst) #\$) #t)
(else
(loop (cdr lst))))))))
(define send-name-collision-err-webpage
(lambda ()
(display "Content-Type: text/html")
(newline)
(newline)
(display html-begin)
(display
(combine (list "<p>"
"Sorry, the provided new directory name is invalid. Please select another directory name."
"</p>")))
(display form-to-create-a-new-sub-directory)
(display html-end)))
(when (and (not (start-with-valid-character? new-sub-dir))
(has-dollar-sign? new-sub-dir))
(begin
(send-invalid-directory-name-webpage)
(error "Sorry, the provided directory name is invalid.")))
;; When everything seemed OK, let us create a new sub-directory for the webmaster.
;; It is quite simple to do the job, since Racket has the built-in function for it:
(make-directory new-sub-dir)
;; When the new sub-directory is created, then we should prepare an HTML list
;; for the webmaster.
(define make-subdirs-items
(lambda (list-of-subdirs)
(let loop ([s ""]
[l list-of-subdirs])
(if (null? l) s
(loop (string-append
s
(interpolate-string "<li ~><a href=~>~</a></li>"
(list (combine (list "class="
"\"subdir\""))
(combine (list "http://www.xxxx.com/"
(car l)))
(car l))))
(cdr l))))))
(define subdirs-items
(make-subdirs-items list-of-subdirs))
(define make-html-list-of-sub-dirs
(lambda (subdirs-items)
(if (null? subdirs-items)
;; true-part
(combine
(list "<div>"
"<p>The new sub-directory was not created successfully.</p>"
"</div>"))
;; false-part
(combine
(list "<div>"
"<ul>"
subdirs-items
"</ul>"
"</div>")))))
(define html-list-of-sub-dirs
(make-html-list-of-sub-dirs subdirs-items))
;; Finally, we can feedback a normal web page indicating a new subdirectory
;; is successfully created under the specified parent directory:
(begin
;; response header
(display "Content-Type: text/html")
(newline)
(newline)
;; html web page
(display
(combine
(list html-begin
(interpolate-string "<p>A new directory named ~ was created successfully.</p>"
(list new-sub-dir))
html-list-of-sub-dirs
"<hr/>"
html-end))))
;;; -----------------------------------------------------------------
;;; End.
;;; -----------------------------------------------------------------
[培训]《安卓高级研修班(网课)》月薪三万计划，掌握调试、分析还原ollvm、vmp的方法，定制art虚拟机自动化脱壳的方法
