(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)))))

          )
         ;;;;     public
         (public

          (define (read-in path)
             (rd (open-input-file path)))
           
          ;;;;        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)
           (begin
             (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), or, when no connection can be made, " (s% "'no-contact")
                       ))
           (form-post url)
           (with-handlers ((exn:fail? (lambda (exn) 'no-contact)))
                          (begin
                            (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), or, when no connection can be made, " (s% "'no-contact")
                  ))
            (post url)
            (with-handlers ((exn:fail? (lambda (exn) 'no-contact)))
                           (begin
                             (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>")
              (sp (s%% "Returns         : ") (s% "<input-port>") " (can be used to read the results of the post), or, when no connection can be made, " (s% "'no-contact")
                  ))
            (get url)
            (with-handlers ((exn:fail? (lambda (exn) 'no-contact)))
                           (begin
                             (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)
            (begin
              (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