#lang scheme/base

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

         web-server/http/cookie
         web-server/http/cookie-parse
         web-server/http
         
         net/head
         scheme/list
         scheme/port
         scheme/file
         scheme/class
         scheme/string)

(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 (displace source)
  (define dest (let-values (((base name is-dir?) (split-path source)))
                 (build-path base "feep.sqlite")))
  (depending-on
   dest
   (list source)
   (λ (dest deps)
     (log:info "Displacing the cookie file (because firefox sucks)")
     (call-with-input-file source
       (λ (input)
         (call-with-output-file dest
           #:exists 'replace
           (λ (output)
             (copy-port input output)))))))
  dest)

(define cookie-file
  (displace
   (car
    (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 cookie-file]))

(define temp-cookies null)

(define (property-name? s)
  (case (string->symbol s)
    ((path domain expires secure) #t)
    (else #f)))

(define (strip s)
  (regexp-replace #px"^\\s+"
                  (regexp-replace #px"\\s+$"
                                  s
                                  "")
                  ""))
  

(define null-hash (make-immutable-hash null))

(define (combine cookie result)
  (if (eq? cookie null-hash) result (cons cookie result)))

(define (parse-for-cookie value next)
  (when value
    (let ((pairs (map (λ (i) (let ((match (regexp-match #rx"([^=]+)=(.+)" i)))
                               (if match
                                   (cons (strip (cadr match)) (strip (caddr match)))
                                   (cons (strip i) #f))))
                      (regexp-split #rx";" value))))
      (next
       (make-immutable-hash
        (list*
         (cons "name" (car (car pairs)))
         (cons "value" (cdr (car pairs)))
         (cdr pairs)))))))
        
(define add-cookies! 
  (let ((check (send db prepare "SELECT id FROM moz_cookies WHERE host = ? AND path = ? AND name = ?"))
        (update (send db prepare "UPDATE moz_cookies SET value = ? WHERE id = ?"))
        (insert (send db prepare "INSERT INTO moz_cookies (name,value,host,path,expiry,isSecure) VALUES (?,?,?,?,?,?)")))
    (λ (header)
      (with-transaction
       db
       (for-each
        (λ (field)
          (when (equal? (car field) "Set-Cookie")
            (log:info "hmm ~s" field)
            (parse-for-cookie
             (cdr field)
             (λ (cookie)
               (log:info "coo ~s" cookie)
               (let ((id (send check once (hash-ref cookie "domain") (hash-ref cookie "path") (hash-ref cookie "name"))))
                 (if id
                     (let ((id (vector-ref id 0)))
                       (log:info "Updating ~s with ~s" id cookie)
                       (send update once (hash-ref cookie "value") id))
                     (begin
                       (send insert once 
                             (hash-ref cookie "name")
                             (hash-ref cookie "value")
                             (hash-ref cookie "domain")
                             (hash-ref cookie "path")
                             (hash-ref cookie "expires" (lambda () #f))
                             (hash-ref cookie "secure" (lambda () 0))))))))))
        (extract-all-fields header))))))

(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)
  (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 add-cookies!)