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.
;;; -----------------------------------------------------------------

[注意]传递专业知识、拓宽行业人脉——看雪讲师团队等你加入！