#lang racket/base

(require (prefix-in log: (planet synx/log:1))
         (planet synx/util:2/sqlite)
         (only-in (planet synx/maker:2) depending-on)
         net/url-structs
         srfi/43
         web-server/http/cookie
         web-server/http/cookie-parse
         web-server/http
         net/head
         racket/list
         racket/port
         racket/file
         racket/class
         racket/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)
  (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 (https://bugzilla.mozilla.org/show_bug.cgi?id=533338))")
     (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 (cadr (regexp-match #rx"([^=]+)" i))) ""))))
            (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 (?,?,?,?,?,?)")))
    (λ (default-domain header)
      (with-transaction
       db
       (for-each
        (λ (field)
          (when (equal? (car field) "Set-Cookie")
            (parse-for-cookie
             (cdr field)
             (λ (cookie)
               (let ((domain (hash-ref cookie "domain" (λ () default-domain))))
                 (let ((id
                        (send check once
                          domain
                          (hash-ref cookie "path")
                          (hash-ref cookie "name"))))
                   (if id
                     (let ((id (vector-ref id 0)))
                       (send update once (hash-ref cookie "value") id))
                     (begin
                       (send insert once
                         (hash-ref cookie "name")
                         (hash-ref cookie "value")
                         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)
      (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?)))
    (begin0
      (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!)