#lang scheme
(require
 (lib "31.ss" "srfi")
 (lib "md5.ss" "file"))

(define (md5-bytes in)
  (let* ([chars (bytes->string/utf-8 (md5 in))]
         [count (/ (string-length chars) 2)]
         [bytes (make-bytes count)])
    (for ([i (in-range 0 count)])
      (let ([j (* i 2)])
        (bytes-set! bytes i (string->number (substring chars j (+ j 2)) 16))))
    bytes))
    
(define growl%
  (class object%
    (init-field
     name
     notifications)
    
    (init
     [hostname "localhost"]
     [port-no 9887]
     [log-sync-timeout 30])
    
    (super-new)
    
    (define custodian
      (make-custodian))
    
    (define socket
      (parameterize ([current-custodian custodian])
        (udp-open-socket hostname port-no)))
    
    (define log-receivers
      '())
    
    (udp-connect! socket hostname port-no)
    (let ([message (open-output-bytes 'message)]
          [name (string->bytes/utf-8 name)]
          [defaults (for/fold ([defaults '()]) ([i (in-naturals)] [n notifications])
                      (if (or (null? (cddr n)) (caddr n))
                          (cons i defaults)
                          defaults))])
      (write-byte 1 message) ; protocol version 1
      (write-byte 0 message) ; registration, MD5 auth
      
      (write-bytes (integer->integer-bytes (bytes-length name) 2 #f #t) message)
      (write-byte (length notifications) message)
      (write-byte (length defaults) message)
      
      (write-bytes name message)
      (for ([n notifications])
        (let ([type (string->bytes/utf-8 (cadr n))])
          (write-bytes (integer->integer-bytes (bytes-length type) 2 #f #t) message)
          (write-bytes type message)))
      (for ([d defaults])
        (write-byte d message))
      
      (write-bytes (md5-bytes (get-output-bytes message)) message)
      
      (udp-send socket (get-output-bytes message)))

    (define log-thread
      (parameterize ([current-custodian custodian])
        (thread
         (rec (loop)
           (when (null? log-receivers)
             (thread-suspend (current-thread)))
           (match (apply sync/timeout log-sync-timeout (map cdr log-receivers))
             [(vector id title description priority sticky?)
              (notify id
                      #:title title #:description description
                      #:priority priority #:sticky sticky?)]
             [_
              (void)])
           (loop)))))
    
    (define/public (notify id
                           #:title [title name] #:description description
                           #:priority [priority 0] #:sticky [sticky? #f])
      (let ([n (assoc id notifications)])
        (let ([message (open-output-bytes 'message)]
              [name (string->bytes/utf-8 name)]
              [type (string->bytes/utf-8 (cadr n))]
              [title (string->bytes/utf-8 title)]
              [description (string->bytes/utf-8 description)])
          (write-byte 1 message) ; protocol version 1
          (write-byte 1 message) ; notification, MD5 auth
          
          (write-bytes
           (integer->integer-bytes
            (bitwise-ior
             (case (min (max -2 priority) 2)
               [(-2) 12]
               [(-1) 14]
               [( 0) 0]
               [(+1) 2]
               [(+2) 4])
             (if sticky? 1 0))
            2 #f #t)
           message)
          
          (write-bytes (integer->integer-bytes (bytes-length type) 2 #f #t) message)
          (write-bytes (integer->integer-bytes (bytes-length title) 2 #f #t) message)
          (write-bytes (integer->integer-bytes (bytes-length description) 2 #f #t) message)
          (write-bytes (integer->integer-bytes (bytes-length name) 2 #f #t) message)
          
          (write-bytes type message)
          (write-bytes title message)
          (write-bytes description message)
          (write-bytes name message)
          
          (write-bytes (md5-bytes (get-output-bytes message)) message)
      
          (udp-send socket (get-output-bytes message)))))

    (define/public (subscribe-notify logger level id
                                     #:title [title name] #:sticky [sticky? #f])
      (set! log-receivers
            (cons
             (cons logger
                   (wrap-evt (make-log-receiver logger level)
                             (λ (log-event)
                               (vector id
                                       title (vector-ref log-event 1)
                                       (case (vector-ref log-event 0)
                                         [(debug) -1]
                                         [(warning) +1]
                                         [(error fatal) +2]
                                         [else 0])
                                       sticky?))))
             log-receivers))
      (thread-resume log-thread))
    
    (define/public (unsubscribe-notify logger)
      (set! log-receivers
            (filter
             (λ (info)
               (not (eq? (car info) logger)))
             log-receivers)))
    
    (define/public (close)
      (set! log-receivers '())
      (custodian-shutdown-all custodian))))

(provide/contract
 [growl% class?])