#lang scheme

(require (prefix-in log: (planet synx/log))
         (planet synx/util:1/sqlite)
         net/url-structs
         srfi/43

         web-server/http/cookie
         web-server/http/cookie-parse
         web-server/http)

(define (get-tails bits separator [reverse? #f])
  (let loop ([bits bits] [result null])
    (cond
      [(null? bits) result]
      [(null? result) (loop (cdr bits) (list (car bits)))]
      [else (loop (cdr bits) (cons 
                              (if reverse?
                                  (string-append (car result) separator (car bits))
                                  (string-append (car bits) separator (car result))) result))])))

(define (get-host-tails uri)
  ; make sure not to allow anything to be sent to all .com for instance.
  (flatten
   (map
    (λ (i)
      (list i (string-append "." i)))
    (cdr (reverse (get-tails (reverse (regexp-split #rx"\\." (url-host uri))) "."))))))

(define (get-path-components uri)
  (map path/param-path (url-path uri)))

(define (get-path-tails uri)
  (let ([components (reverse (get-path-components uri))])
    (if (null? components) '("/")
        (let ([components
               (if (regexp-match #rx"/$" (car components))
                   components
                   (cdr components))])
          (cons "/" (map (λ (i) (string-append "/" i "/")) (get-tails (reverse components) "/" #t)))))))

(define cookie-files
  (sort
   (fold-files
    (λ (name type result)
      (if (regexp-match #rx"cookies.sqlite$" (path->string name))
          (cons name result)
          result))
    null
    (build-path (find-system-path 'home-dir) ".mozilla" "firefox"))
   >
   #:key (λ (name) (file-or-directory-modify-seconds name))))

(define db (new connection% [path (car cookie-files)]))

(define (cookies-statement host-tails path-tails is-server?)
  (values
   (append host-tails path-tails)
   (apply
    string-append
    (flatten
     (list
      "SELECT "
      (if is-server?
          "name,value,host,path,expiry,isSecure"
          "name,value")
      " FROM moz_cookies INNER JOIN (SELECT MAX(id) as highestID FROM moz_cookies GROUP BY name) AS other "
      " ON moz_cookies.id = other.highestID "
      " WHERE host IN ("
      (string-join (build-list (length host-tails) (λ (i) "?")) ", ")
      ")"
      (if (null? path-tails) ""
          (list
           " AND path IN ("
           (string-join (build-list (length path-tails) (λ (i) "?")) ", ")
           ")")))))))

(define set!-cookie
  (let ((select (send db prepare "SELECT id FROM moz_cookies WHERE name = ? AND host = ? AND path = ?"))
        (insert (send db prepare "INSERT INTO moz_cookies (name,value,host,path,expiry,isSecure) VALUES (?,?,?,?,?,0)"))
        (update (send db prepare "UPDATE moz_cookies SET value = ? WHERE id = ?")))
    (λ (name value host path expires)
      (log:info "Set cookie ~s ~s ~s ~s ~s" name value host path expires)
      (let ((id (send select once)))
        (if id
            (begin
              (send update once value id)
              id)
            (begin
              (send insert once name value host path expires)
              (send db last-insert)))))))

(define (format/set-cookie cookies)
  (map cookie->header cookies))

(define (maybe-quote s)
  (if (regexp-match #px"[\\s\"]" s)
      (string-append
       "\""
       (regexp-replace* #rx"\"" s "\\\"")
       "\"")
      s))

(define (format/cookie cookies)
  (make-header
   #"Cookie"
   (string->bytes/utf-8
    (string-join 
     (map
      (λ (cookie)
        (string-append (client-cookie-name cookie) "="
                       (maybe-quote (client-cookie-value cookie))))
      cookies)
     "; "))))

(define (maybe-dot s)
  (if (equal? (substring s 0 1) ".") s
      (string-append "." s)))

(define (get-cookies uri [is-server? #f])
  (let-values ([(params sql)
                (cookies-statement
                 (get-host-tails uri)
                 (get-path-tails uri)
                 is-server?)])
    (send/apply 
     db map
     (λ (name value [host #f] [path #f] [expiry #f] [is-secure? #f])
       (if is-server?
           (make-cookie name value
                        #:domain host
                        #:secure? (= 0 is-secure?)
                        #:max-age expiry
                        #:path path)
           (make-client-cookie name value host path)))
     sql params)))

(require net/url)

(define (test)
  (local
    [(define (make-thread i)
       (thread
        (λ ()
          (display
           (format
            "~a~n"
            (let ([thing (format "http://~a.fchan.us" (string-join (build-list (remainder i 20) (λ (i) (number->string i))) "."))])
              (display (format "*** ~a~n" thing))
              (get-cookies (string->url thing))))))))]
    (for-each
     thread-wait
     (map
      make-thread
      (build-list 100 (λ (i) i))))))

(provide get-cookies format/cookie format/set-cookie set!-cookie)