#lang racket

(require drracket/tool
         net/sendurl
         net/url
         net/uri-codec
         racket/date
         racket/gui
         mrlib/include-bitmap
         rackunit)

(provide tool@)


(define db-host "li21-127.members.linode.com")
(define db-submit-port 8022)
(define db-query-port 8021)

;; ignore all but the first 'max-err-len' chars of the error message
(define max-err-len 200)

(define submit-servlet-path (list (path/param "ers-submit" '())))
(define query-servlet-path (list (path/param "errrecorder" '())))

(define submit-url 
 (url "http" #f db-host db-submit-port #t submit-servlet-path `() #f))

(define (query-error-url type-str msg-str)
  (url->string
   (url "http" #f db-host db-query-port #t query-servlet-path
        `((type . ,type-str)
          (msg . ,msg-str))
        #f)))


(define tool@
  (unit
    (import drracket:tool^)
    (export drracket:tool-exports^)
    
    ; Taken from drracket/debug.rkt to create clickable image.
    ; start
    
    (define arrow-cursor (make-object cursor% 'arrow))
    
    (define (clickable-snip-mixin snip%)
      (class snip%
        (init-rest args)
        (inherit get-flags set-flags get-admin get-extent)
        
        (define callback void)
        (define/public (set-callback cb) (set! callback cb))
        (define/public (get-callback) callback)
        
        (define in-bounds? #f)
        (define grabbed? #f)
        
        (define (set-clicked new-grabbed? new-in-bounds? dc)
          (let ([needs-invalidate? (not (eq? (and grabbed? in-bounds?)
                                             (and new-grabbed? new-in-bounds?)))])
            (set! grabbed? new-grabbed?)
            (set! in-bounds? new-in-bounds?)
            (when needs-invalidate?
              (invalidate dc))))
        
        (define/override (draw dc x y left top right bottom dx dy draw-caret)
          (super draw dc x y left top right bottom dx dy draw-caret)
          (when (and in-bounds? grabbed?)
            (let ([brush (send dc get-brush)]
                  [pen (send dc get-pen)])
              (let-values ([(w h) (get-w/h dc)])
                (send dc set-brush (send the-brush-list find-or-create-brush "black" 'hilite))
                (send dc set-pen (send the-pen-list find-or-create-pen "white" 1 'transparent))
                (send dc draw-rectangle x y w h)
                (send dc set-pen pen)
                (send dc set-brush brush)))))
        
        (define/override (on-event dc x y editorx editory evt)
          (let-values ([(w h) (get-w/h dc)])
            (let ([in-bounds? (and (<= (- (send evt get-x) x) w)
                                   (<= (- (send evt get-y) y) h))])
              (cond
                [(send evt button-down? 'left)
                 (set-clicked #t in-bounds? dc)]
                [(send evt button-up? 'left)
                 (let ([admin (send this get-admin)])
                   (when admin
                     (send (send admin get-editor) set-caret-owner #f 'global)))
                 (when (and grabbed? in-bounds?)
                   (callback))
                 (set-clicked #f in-bounds? dc)]
                [else
                 (set-clicked grabbed? in-bounds? dc)]))))
        
        (define/private (invalidate dc)
          (let ([admin (get-admin)])
            (when admin
              (let-values ([(w h) (get-w/h dc)])
                (send admin needs-update this 0 0 w h)))))
        
        (define/private (get-w/h dc)
          (let ([wb (box 0)]
                [hb (box 0)])
            (get-extent dc 0 0 wb hb #f #f #f #f)
            (values (unbox wb)
                    (unbox hb))))
        
        (define/override (adjust-cursor dc x y editorx editory event)
          arrow-cursor)
        
        (apply super-make-object args)
        (set-flags (cons 'handles-events (get-flags)))))
    
    (define (make-note% filename bitmap)
      (and (send bitmap ok?)
           (letrec ([note%
                     (class clickable-image-snip%
                       (inherit get-callback)
                       (define/public (get-image-name) filename)
                       (define/override (copy) 
                         (let ([n (new note%)])
                           (send n set-callback (get-callback))
                           n))
                       (super-make-object bitmap))])
             note%)))
    
    (define clickable-image-snip% (clickable-snip-mixin image-snip%))
    
    ; end
    
    ; errrecorder-note% : my clickalble image
    (define errrecorder-note% 
      (make-note% "syncheck.png"        
                  (include-bitmap (lib "icons/syncheck.png") 'png/mask)))
    
    ; display-errrecorder-button : string? string? -> nothing
    ; adds button to gui
    (define (display-errrecorder-button exn-type msg)
      (when errrecorder-note%
        (when (port-writes-special? (current-error-port))
          (let ([note (new errrecorder-note%)])
            (send note set-callback 
                  (λ () (send-url 
                         (query-error-url exn-type msg))))
            (write-special note (current-error-port))
            (display #\space (current-error-port))))))
    
    
    ; errrecorder-language<%> : an empty interface
    (define errrecorder-language<%>
      (interface ()))
    
    ; errrecorder-language-extension : object? -> object?
    ; produces a language-extension/mixin that modifies the error-display-handler
    (define (errrecorder-language-extension super%)
      (class* super% (errrecorder-language<%>)
        
        (define/override (on-execute settings run-in-user-thread)
          (super on-execute settings run-in-user-thread)
          (run-in-user-thread
           (λ () (let ([current-error-display-handler (error-display-handler)])
                   (error-display-handler 
                    (make-errrecorder-error-display-handler current-error-display-handler))))))
        
        (super-new)))
    
    ; make-errrecorder-error-display-handler : string? exn? -> nothing
    ; adds errrecorder button to gui before normal display handler is called
    (define ((make-errrecorder-error-display-handler
              current-error-display-handler) msg exn)
      
      (define msg-with-syntax-info (maybe-add-syntax-err-info msg exn))
      (define trimmed-msg 
        (substring 
         msg-with-syntax-info
         0
         (min max-err-len (string-length msg-with-syntax-info))))
      (define exn-type (extract-exn-type exn))
      
      (send-error-request exn-type trimmed-msg)
      (display-errrecorder-button exn-type trimmed-msg)
      (current-error-display-handler msg exn))
    
    ; phase1 : nothing -> nothing
    ; extends language interfaces with errrecorder interface
    (define (phase1) (drracket:language:extend-language-interface 
                      errrecorder-language<%>
                      (λ (super%) (errrecorder-language-extension super%))))
    
    ; phase2 : nothing -> nothing
    ; does nothing but is required
    (define (phase2) (void))
    
    ))



; send-error-request : string? string? -> nothing
; sends error information to server
(define (send-error-request exn-type msg)
  (log-error-wrapper
   (λ () 
     (define in-port
       (post-pure-port
        submit-url 
        (bindings->post-bytes 
         `((type ,exn-type) 
           (time ,(number->string (current-seconds)))
           (msg ,msg)))))
     ;; ignore the result:
     (close-input-port in-port))))

; log-error-wrapper : (-> 'b) -> 'b
; evaluate the given function, spool the error message
; to the error log on a network failure
(define (log-error-wrapper func)
  (with-handlers 
      ([exn:fail:network? 
        (λ (exn)
          (log-error 
           (format 
            "unable to connect to ErrRecorder server: ~a" 
            (exn-message exn))))])
    (func)))

;; maybe-add-syntax-err-info : string exn -> string
;; for syntax errors, the text of the source code becomes
;; a part of the error message.  Extract and add it to
;; the message for syntax errors.
(define (maybe-add-syntax-err-info msg exn)
  (cond [(exn:fail:syntax? exn)
         (define sources (for/list ([expr (in-list (exn:fail:syntax-exprs exn))])
                           (format "~a" (syntax->datum expr))))
         (match sources
           [(list) msg]
           [(list a) (string-append msg " in: " a)]
           [longer-list (string-append msg " in: "
                                       (apply string-append
                                              (add-between sources "\n")))])]
        [else msg]))

; string->post-bytes : string? -> bytes?
; converts string into url-encoded bytes
(define (string->post-bytes s)
  (string->bytes/utf-8
   (form-urlencoded-encode s)))

; symbol->post-bytes : symbol? -> bytes?
; converts symbol into url-encoded bytes
(define symbol->post-bytes
  (compose string->post-bytes symbol->string))

; bindings->post-bytes : (list (symbol? string?)) -> bytes?
; converts a list of symbol to string bindings into url-encoded bytes
(define (bindings->post-bytes bindings)
  (apply 
   bytes-append
   (add-between
    (for/list ([pr (in-list bindings)])
      (bytes-append (symbol->post-bytes (first pr)) #"="
                    (string->post-bytes (second pr))))
    #"&")))

(check-equal? 
 (bindings->post-bytes `((abc "rhumba") (def "zumpa zumpa\tzumpa")))
 #"abc=rhumba&def=zumpa+zumpa%09zumpa")

; extract-exn-type : exn? -> string?
; extracts the exn type out of the exn message
(define (extract-exn-type exn)
  (cond [(exn? exn)
         (let-values ([(struct-type skipped?) (struct-info exn)])
           (match struct-type
             [#f "no exn type found"]
             [struct-type
              (let-values ([(type dc2 dc3 dc4 dc5 dc6 dc7 dc8) 
                            (struct-type-info struct-type)])
                (symbol->string type))]))]
        [else "not-an-exception"]))


(check-equal? (extract-exn-type (exn:fail "frooty" 
                                          (current-continuation-marks)))
              "exn:fail")
(check-equal? (extract-exn-type 
               (exn:fail:contract:divide-by-zero
                "frooty" 
                (current-continuation-marks)))
              "exn:fail:contract:divide-by-zero")