(module bot mzscheme
        (require (lib "url.ss" "net"))
        (require (lib "uri-codec.ss" "net"))
        (require (lib "base64.ss" "net"))
        (require (lib "string.ss" "mzlib"))
	(require (lib "string.ss" "srfi" "13"))
        (require (planet "roos.scm" ("oesterholt" "roos.plt" 1 4)))
        (provide form-data
                 (all-from (planet "roos.scm" ("oesterholt" "roos.plt" 1 4))) 
                 (all-from (lib "url.ss" "net"))
                 )
         
        ;;;; multipart/form-data
        (def-class 
         (roos-doc (sp "This class can be used to post forms using the " (s% "multipart/form-data") " content-type."
                       "It can be used to act as a posting client, to post forms to websites, e.g. a MediaWiki."
                       )
                   (sp (s== "Synopsys"))
                   (sp (sverb "(require (planet \"bot.scm\" (\"oesterholt\" \"webbot.plt\" 1 0))"
                              "(define F (form-data))"
                              "(-> F form-add 'name \"A name\")"
                              "(-> F form-add 'file (build-path \"my-file.txt\"))"
                              "(let ((p (-> F form-post (string->url \"http://test.form.org/post-it.php\"))))"
                              "   (display (read-string 1000000 p))"
                              "   (close-input-port p))"
                              "(exit)")))
         (this (form-data))
         (supers)
         ;;;;     private
         (private
          (define _form      '())
          (define _boundary  "87689sadfgioawgfaout786TUGDQO@ggdfyudfsgajsguygOI*USW")
	  
	  ;;;; user agent
	  (define _user-agent      "User-Agent: Mozilla/2.0 mzscheme-webbot/1.1")
	  (define _accept          "Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, image/png, */*")
          (define _accept-charset  "Accept-Charset: iso-8859-1,*,utf-8")
	  (define _accept-language "Accept-Language: en-US")

          ;;;; Current url
          (define _url       #f)
          
          ;;;; Basic Authentication
          (define _uid       #f)
          (define _pass      #f)
          
          ;;;; Cookies
          (define _cookies   (make-hash-table))
          
          ;;;; redirects
          (define _redirect  #f)
          (define _location  "")

          
          ;;;; interpret header
          (define (substr s from . _to)
            (let ((to (if (null? _to) 
                          (string-length s)
                          (car _to))))
              (let ((l (string-length s)))
                (substring s from (if (> l to) to l)))))
          
          (define (process-cookie c)
            (let ((cookie-list (regexp-split "[=]" c)))
              (let ((cookie (string->symbol (car cookie-list)))
                    (value1  (apply string-append (cdr cookie-list))))
                (let ((value-list (regexp-split "[;]" value1)))
                  (let ((value (car value-list)))
                    ;(display (format "cookie:~a, value:~a~%" cookie value))
                    (hash-table-put! _cookies cookie value))))))
          
          (define (process-http S)
            (let ((http-list (regexp-split "[ ]" S)))
              (let ((code (string->number (cadr http-list))))
                (if (or (= code 301) (= code 302))
                    (set! _redirect #t)))))
          
          (define (process-location S)
            (set! _location (string->url S))
            (set-url-port! _location (url-port _url)))
          
          (define (interpret header)
            (let ((lines (regexp-split "\r\n" header)))
              
              (define (interpret-lines L)
                (if (null? L)
                    #t
                    (let ((S (car L)))
		      ;(display (format "http:line = ~a~%" S))
                      (cond
                       ((string-ci=? (substr S 0 11) "set-cookie:") (process-cookie (substr S 12)))
                       ((string-ci=? (substr S 0 5)  "http/")       (process-http S))
                       ((string-ci=? (substr S 0 9)  "location:")   (process-location (substr S 10))))
                      (interpret-lines (cdr L)))))
              
              (set! _redirect #f)
              (interpret-lines lines)))
          
          (define (rd port)
            (let ((r (read-string 1024 port)))
              (if (eq? r eof)
                  (begin
                    (close-input-port port)
                    "")
                  (string-append r (rd port)))))
          
          (define (read-in path)
             (rd (open-input-file path)))
           
          )
         ;;;;     public
         (public

	  ;;;;        headers
	  (define (headers . my-own)

	    (define (result my-own)
	      (append (list _user-agent _accept _accept-charset _accept-language) (authorize) (cookies) my-own))

	    (if (not (null? my-own))
		(if (list? (car my-own))
		    (result (car my-own))
		    (result my-own))
		(result my-own)))

	  ;;;;        authorize
	  (define (authorize)
	    (if (eq? _uid #f)
		(list)
		(list (let ((s (string-append _uid ":" _pass)))
			(string-append "Authorization: Basic " 
				       (string-trim-both (bytes->string/utf-8 (base64-encode (string->bytes/utf-8 s)))))))))


          ;;;;        cookies
          ((define (sp "Returns the curren stored cookies, as they would be send to the http server."))
           (cookies)
            (let ((S "Cookie: ")
                  (sc ""))
              (hash-table-for-each _cookies (lambda (key val) 
                                              (set! S (string-append S sc (symbol->string key) "=" val ))
                                              (set! sc ";")))
	      ;(display (format "cookies: ~a (~a)~%" S sc))
	      (list S)))
          
          ;;;;        cookie
          ((define (sp "Returns #f, if c is not found, the value of the cookie of c otherwise"))
           (cookie c)
            (if (string? c) 
                (cookie (string->symbol c))
                (hash-table-get _cookies c (lambda () #f))))

	  ;;;;        cookie-match
	  ((define (sp "Returns #f, if c is not matched, the value of the cookie of c otherwise"))
	   (cookie-match c)
	     (let ((found #f))
	       (hash-table-for-each _cookies (lambda (key value)
					       (let ((K (symbol->string key)))
						 (if (regexp-match (symbol->string c) (symbol->string key))
						     (set! found value)))))))
          
          ;;;;        form-add
          ((define (sp "This member can be used to add a (form) field to be posted. It automatically does the "
                       "right thing given it's input value. If value is of type " (s% 'path?) " the form will "
                       "add the file to be uploaded; otherwise the string representation of the input value "
                       "is taken (using " (s% "format") ".")
                   (sp (s% "Input parameters: ") (s% 'name:<symbol>) ", " (s% 'value:<anytype>) ".")
                   (sp (s% "Returns         : ") (s% 'this)))
            (form-add name value)
              (set! _form (cons (cons name (format "~a" value)) _form))
              this)
          
          ;;;;        form-clear
          ((define (sp "Clears the form. New fields can be added.")
                   (sp (s% "Returns         : ") (s% 'this)))
             (form-clear)
               (set! _form '())
               this)
          
          ;;;;        form->bytes
          ((define (sp "Converts the form to a 'bytes' representation.")
                   (sp (s% "Returns         : ") "The converted form"))
             (form->bytes) 
               (values (list (string-append "Content-type: multipart/form-data, boundary=" _boundary)
                             )
                       (string->bytes/utf-8
                        (apply string-append
                               (map (lambda (field-value)
                                      (string-append (format "--~a~%" _boundary)
                                                     (if (path? (cdr field-value))
                                                         (string-append
                                                          (format "content-disposition: form-data; name=\"~a\"; filename=\"~a\"\r\n"
                                                                  (symbol->string (car field-value))
                                                                  (call-with-values (lambda () (split-path (cdr field-value)))
                                                                                    (lambda (p n x) n)))
                                                          (format "Content-Transfer-Encoding: binary~%")
                                                          (format "~%")
                                                          (read-in (cdr field-value)))
                                                         (string-append
                                                          (format "content-disposition: form-data; name=\"~a\"\r\n" (symbol->string (car field-value)))
                                                          (format "\r\n")
                                                          (format "~a\r\n" (cdr field-value))))))
                                    _form)))))
          ;;;;        form-post
          ((define (sp "Posts the form to the given " (s% 'url))
                   (sp (s%% "Input parameters: ") (s% "url:<url|string>") " (see the " (s% "net") " collection)")
                   (sp (s%% "Returns         : ") (s% "<input-port>") " (can be used to read the results of the post")) 
            (form-post url)
	      (current-alist-separator-mode 'amp)
              (if (string? url) (set! url (string->url url)))
              (set! _url url)
	      (call-with-values (lambda () (-> this form->bytes))
		(lambda (content-types data)
		  (let ((P (post-impure-port url data (headers content-types))))
		    (interpret (purify-port P))
		    (if _redirect
			(begin
			  (close-input-port P)
			  (get _location))
			P)))))
          
          ((define (sp "Posts the form to the given " (s% 'url))
                   (sp (s%% "Input parameters: ") (s% "url:<url|string>") " (see the " (s% "net") " collection)")
                   (sp (s%% "Returns         : ") (s% "<input-port>") " (can be used to read the results of the post")) 
            (post url)
	      (current-alist-separator-mode 'amp)
              (if (string? url) (set! url (string->url url)))
              (set! _url url)
	      (let ((P (post-impure-port url (string->bytes/utf-8 "") (headers))))
		(interpret (purify-port P))
		(if _redirect
		    (begin
		      (close-input-port P)
		      (form-post _location))
		    P)))

	  ((define (sp "Gets the page given by " (s% 'url) ":<url|string>"))
	     (get url)
	       (current-alist-separator-mode 'amp)
	       (if (string? url) (set! url (string->url url)))
	       (set! _url url)
	       (let ((P (get-impure-port url (headers))))
		 (interpret (purify-port P))
		 (if _redirect
		     (begin
		       (close-input-port P)
		       (get _location))
		     P)))
          
          ;;;;        basic-auth
          ((define (sp "Sets uid and password for basic authorization."))
             (basic-auth uid pass)
                (set! _uid uid)
                (set! _pass pass))
          
          
          ;;;;        read-page
          ((define (sp "Reads the whole contents from the port returned by 'form-post' or 'post'"))
             (read-page port)
               (rd port))
          
          )
         ;;;;     constructor
         ((constructor (sp "Takes no arguments"))
          (current-alist-separator-mode 'amp)
          )
         )
        
        
        );;; module