(import scheme)
(import (chicken base))
(import (chicken file))
(import (chicken format))
(import (chicken io))
(import (chicken irregex))
(import (chicken pathname))
(import (chicken process))
(import (chicken process-context))
(import (chicken process-context posix))
(import (chicken sort))
(import (chicken string))
(import (srfi 1))
(import gtk-server)

(define (read-string* #!optional num port)
  (let ((output (read-string num port)))
    (if (eof-object? output)
        ""
        output)))

(define (capture command-string)
  (call-with-input-pipe command-string
    (lambda (in)
      (string-chomp (read-string* #f in)))))

(define fifo (format "/tmp/mpg.fifo.~a" (current-process-id)))

(define (fifo-write line)
  (call-with-output-file fifo
    (lambda (out)
      (write-line line out))
    #:append))

(define mpg123 (capture "which mpg123 2>/dev/null"))
(when (equal? mpg123 "")
  (print "ERROR: no 'mpg123' binary found! Please install mpg123 first. Exiting...")
  (exit 1))

;; Start mpg123
(when (file-exists? fifo)
  (delete-file fifo))

(receive (_ _ pid)
    (process mpg123 `("-o" "pulse,openal,alsa" "-R" "--fifo" ,fifo))
  (on-exit (lambda () (process-wait pid))))

;; Make sure the FIFO file is available
(let loop ()
  (when (not (file-exists? fifo))
    (loop)))

(define gtk-server (start-gtk-server!))
(define (gtk #!rest args) (apply gtk-send! gtk-server args))

;; Verify availability of WGET
(define wget (capture "which wget 2>/dev/null"))
(when (equal? wget "")
  (print "WARNING: no 'wget' binary found! Cannot show the name of current stream and .m3u .pls lists are not supported"))

(define cfg (make-pathname (get-environment-variable "HOME") ".radio.cfg"))
(define stations '())
(define counter 0)
(define toggle 0)

;; Define GUI - mainwindow
(define win (gtk "m_window" "\"'GTK-server Internet Radio'\"" 400 320))
;; Attach frame #1
(define frame1 (gtk "m_frame" 220 260))
(gtk "m_attach" win frame1 5 5)
(gtk "m_frame_text" frame1 "\"' Stations '\"")
;; Define list
(define lst (gtk "m_list" 200 190))
(gtk "m_attach" win lst 15 25)
;; Buttons
(define add (gtk "m_stock" 'gtk-add 90 30))
(gtk "m_attach" win add 15 225)
(define del (gtk "m_stock" 'gtk-delete 90 30))
(gtk "m_attach" win del 125 225)
;; Attach frame #2
(define frame2 (gtk "m_frame" 165 60))
(gtk "m_attach" win frame2 230 5)
(gtk "m_frame_text" frame2 "\"' Control '\"")
(define play (gtk "m_stock" 'gtk-media-play 50 30))
(gtk "m_attach" win play 240 25)
(define pause (gtk "m_stock" 'gtk-media-pause 50 30))
(gtk "m_attach" win pause 310 25)
;; Attach frame #3
(define frame3 (gtk "m_frame" 165 60))
(gtk "m_attach" win frame3 230 205)
(gtk "m_frame_text" frame3 "\"' Info '\"")
(define about (gtk "m_stock" 'gtk-about 50 30))
(gtk "m_attach" win about 240 225)
(define exit (gtk "m_stock" 'gtk-quit 50 30))
(gtk "m_attach" win exit 320 225)

;; Config panel
(define config (gtk "m_window" "\"'Add Station'\"" 300 180))
(gtk "m_hide" config)
;; Attach frame #4
(define frame4 (gtk "m_frame" 290 60))
(gtk "m_attach" config frame4 5 5)
(gtk "m_frame_text" frame4 "\"' Name '\"")
;; Entry for name
(define inp (gtk "m_entry" "\"''\"" 280 50))
(gtk "m_attach" config inp 10 15)
;; Attach frame #5
(define frame5 (gtk "m_frame" 290 60))
(gtk "m_attach" config frame5 5 75)
(gtk "m_frame_text" frame5 "\"' URL '\"")
;; Entry for url
(define url (gtk "m_entry" "\"''\"" 280 50))
(gtk "m_attach" config url 10 85)
;; Ok button
(define ok (gtk "m_stock" 'gtk-ok 50 30))
(gtk "m_attach" config ok 5 145)
;; Cancel button
(define cancel (gtk "m_stock" 'gtk-cancel 50 30))
(gtk "m_attach" config cancel 100 145)

;; About dialogue
(define ver (gtk "gtk_server_version"))
(define abd (gtk "m_dialog"
                 "\"' About this program '\""
                 (format "\"'In memory of Qradio. Running with GTK-server ~a !'\""
                         ver)
                 300
                 100))

;; Error dialogue
(define err (gtk "m_dialog" "\"' ERROR '\"" "\"'Provided link cannot be opened! Skipping it...'\"" 300 100))

;; Attach frame #6
(define frame6 (gtk "m_frame" 390 45))
(gtk "m_attach" win frame6 5 270)
(gtk "m_frame_text" frame6 "\"' Stream Title '\"")
(define label (gtk "m_label" "\"''\"" 370 40 0.5 0.5 50))
(gtk "m_attach" win label 10 280)

;; Attach frame #7
(define frame7 (gtk "m_frame" 165 130))
(gtk "m_attach" win frame7 230 70)
(define canvas (gtk "m_canvas" 155 100))
(gtk "m_attach" win canvas 235 90)
(gtk "m_out" "\"'Back to Qradio'\"" "#0000FF" "#CACACA" 10 80)
(define logo-file (pathname-replace-extension (program-name) ".png"))
(gtk "m_image" (format "\"'~a'\"" logo-file))

(define current -1)
(define sel -1)

;; Read config in list
(define (read-config-from-file)
  (when (file-exists? cfg)
    (set! stations
          (let ((content (call-with-input-file cfg
                           (lambda (in)
                             (read-string* #f in)))))
            (filter-map
             (lambda (block)
               (let ((station (filter-map
                               (lambda (line)
                                 (and-let* ((idx (substring-index "=" line))
                                            (key (substring line 0 idx))
                                            (value? (> (string-length line) idx))
                                            (value (substring line (+ idx 1))))
                                   (cons (string->symbol key) value)))
                               (string-split block "\n"))))
                 (and (alist-ref 'name station)
                      (alist-ref 'url station)
                      station)))
             (string-split content "#"))))))

;; Set configfile into a list widget
(define (add-stations-to-list)
  (gtk "gtk_list_store_clear" lst)
  (for-each
   (lambda (station)
     (and-let* ((name (alist-ref 'name station)))
       (gtk "m_list_text" lst (format "\"'~a'\"" name))))
   stations))

;; Save all stations to config in alphabetical order
(define (save-stations-to-file)
  (call-with-output-file cfg
    (lambda (out)
      (for-each
       (lambda (station)
         (fprintf out "name=~a\n" (alist-ref 'name station))
         (fprintf out "url=~a\n" (alist-ref 'url station))
         (fprintf out "#\n"))
       (sort stations (lambda (a b)
                        (string<? (alist-ref 'name a)
                                  (alist-ref 'name b))))))))

;; Obtain stream title
(define (get-title-from-stream)
  (if (>= current 0)
      (let ((url (alist-ref 'url (list-ref stations current))))
        (if (not (equal? wget ""))
            (let* ((data (string-split (capture (format "~a --timeout=1 --tries=1 --header='Icy-Metadata: 1' ~a -O - 2>/dev/null | head -c 65536 | strings" wget (qs url))) "\n"))
                   (title-match (any (lambda (line)
                                      (irregex-search "StreamTitle=([^;]+);" line))
                                    data)))
              (if title-match
                  (let ((title (irregex-match-substring title-match 1)))
                    (if (> (string-length title) 1)
                        (string-translate title "\"'")
                        url))
                  url))
            url))
      ""))

(define (delete-at items n)
  (let loop ((i 0)
             (items items)
             (acc '()))
    (if (pair? items)
        (if (= i n)
            (loop (+ i 1) (cdr items) acc)
            (loop (+ i 1) (cdr items) (cons (car items) acc)))
        (reverse acc))))

(read-config-from-file)
(add-stations-to-list)

;; Set a timeout 15 sec to update name of stream
(gtk "m_timeout" label 15000)

;; Mainloop
(let loop ()
  (let ((event (gtk "m_event")))
    (when (not (member event (list win exit)))
      (cond
       ((equal? event about)
        (gtk "m_show" abd))
       ((equal? event abd)
        (gtk "m_hide" abd))
       ((equal? event err)
        (gtk "m_hide" err))
       ((equal? event add)
        (gtk "m_show" config))
       ((equal? event del)
        (let ((sel (string->number (gtk "m_list_get" lst))))
          (when (>= sel 0)
            (set! stations (delete-at stations sel))
            (gtk "m_list_text" lst "\"''\"")
            (save-stations-to-file)
            (read-config-from-file)
            (add-stations-to-list))))
       ((equal? event ok)
        (let* ((name (gtk "m_entry_grab" inp))
               (url (gtk "m_entry_grab" url))
               (station `((name . ,name) (url . ,url))))
          (set! stations (cons station stations))
          (gtk "m_list_text" lst "\"''\"")
          (save-stations-to-file)
          (read-config-from-file)
          (add-stations-to-list)
          (gtk "m_hide" config)))
       ((equal? event cancel)
        (gtk "m_entry_text" inp "\"''\"")
        (gtk "m_entry_text" url "\"''\"")
        (gtk "m_hide" config))
       ((equal? event pause)
        (when (= toggle 0)
          (fifo-write "PAUSE")
          (set! toggle 1)))
       ((equal? event play)
        (when (= toggle 1)
          (fifo-write "PAUSE")
          (set! toggle 0)))
       ((equal? event label)
        (when (not (= current -1))
          (gtk "m_label_text" label (format "\"'~a'\"" (get-title-from-stream)))))
       ;; Ignore keyboard and mouse
       ((member event '("key-press-event" "motion-notify" "button-press" "button-release")))
       (else
        (gtk "m_event" "update")
        (set! toggle 0)
        (let ((sel (string->number (gtk "m_list_get" lst))))
          ;; Only take action if list was changed
          (when (not (= current sel))
            (set! current sel)
            (if (file-exists? fifo)
                (begin
                  (fifo-write "SILENCE")
                  (let ((station (list-ref stations current)))
                    (fifo-write (format "LOAD ~a" (alist-ref 'url station))))
                  (gtk "m_label_text" label (format "\"'~a'\"" (get-title-from-stream))))
                (print "No interface to 'mpg123' found! Restart this program and try again."))))))
      (loop))))

;; Stop and exit
(fifo-write "QUIT")
(delete-file* fifo)

;; Save configuration
(save-stations-to-file)

(gtk "m_end")
(stop-gtk-server! gtk-server)