rackout.rkt
#lang racket/base
;; Copyright Neil Van Dyke.  See file "info.rkt".

(require (for-syntax racket/base)
         json
         net/dns
         planet/version
         racket/cmdline
         racket/contract
         racket/file
         racket/runtime-path
         racket/system
         web-server/dispatch
         web-server/servlet
         web-server/servlet-env
         "planet-neil-hostname.rkt"
         "planet-neil-sudo.rkt"
         "planet-neil-vlc.rkt"
         "planet-neil-web-server-xexp.rkt"
         "rackout-about.rkt"
         "rackout-dvd-title.rkt"
         "rackout-splash.rkt"
         "rackout-xrandr.rkt")

;; Note: This "require" of "racket/match/parse" is to possibly work around a
;; bug introduced in 5.3.1.  See Matthew Flatt message from 2012-11-11.  Bug is
;; "standard-module-name-resolver: collection not found\n collection:
;; \"racket/match\"" when running result of "raco exe" or "raco distribute".
(require (for-syntax racket/match/parse))

(module+ test
  (require "planet-neil-overeasy.rkt"))

;;------------------------------------------------------------------- Custodian

(define main-custodian (current-custodian))

;;--------------------------------------------------------------------- Options

(define current-port-forwarding?  (make-parameter #t))
(define current-internal-hostname (make-parameter #f))
(define current-internal-port     (make-parameter 8000))

;; (define current-external-hostname (make-parameter #f))
(define current-external-port     (make-parameter (if (current-port-forwarding?)
                                                      80
                                                      (current-internal-port))))

;;-----------------------------------------------------------------------------

;; (define current-external-base-url-string (make-parameter #f))

;; (apply string-append
;;        `("http://"
;;          ,(current-external-hostname)
;;          ,@(let ((port (current-external-port)))
;;              (if (equal? 80 port)
;;                  '()
;;                  `(":"
;;                    ,(number->string port))))
;;          "/"))))

;;-----------------------------------------------------------------------------

(define jquery-version "1.7.1")

(define jquery-mobile-version "1.2.0")

;;---------------------------------------------------- System Command Utilities

(define (system-command-with-stdio-bytes stdin-bytes command . args)
  (let ((stdout-ob (open-output-bytes))
        (stderr-ob (open-output-bytes))
        (stdin-ib  (open-input-bytes stdin-bytes)))
    (parameterize ((current-output-port stdout-ob)
                   (current-error-port  stderr-ob)
                   (current-input-port  stdin-ib))
      (let ((exit-code (apply system*/exit-code
                              command
                              args)))
        (values exit-code
                (get-output-bytes stdout-ob)
                (get-output-bytes stderr-ob))))))

(define (system-command-with-discarded-output stdin-bytes command . args)
  ;; TODO: Use file null output ports with "subprocess"
  (let ((stdout-ob (open-output-bytes))
        (stderr-ob (open-output-bytes))
        (stdin-ib  (open-input-bytes stdin-bytes)))
    (parameterize ((current-output-port stdout-ob)
                   (current-error-port  stderr-ob)
                   (current-input-port  stdin-ib))
      (let ((exit-code (apply system*/exit-code
                              command
                              args)))
        (values exit-code)))))

(define (system-command-with-discarded-output/sudo stdin-bytes command . args)
  ;; TODO: Use file null output ports with "subprocess"
  (let ((stdout-ob (open-output-bytes))
        (stderr-ob (open-output-bytes))
        (stdin-ib  (open-input-bytes stdin-bytes)))
    (parameterize ((current-output-port stdout-ob)
                   (current-error-port  stderr-ob)
                   (current-input-port  stdin-ib))
      (let ((exit-code (apply system*/exit-code/sudo
                              command
                              args)))
        (values exit-code)))))

(define (system-command-with-stdout-bytes
         #:error-name (error-name 'system-command-with-stdout-bytes)
         #:sudo?      (sudo? #f)
         #:command    command
         #:args       (args '()))
  (let ((stdout-ob (open-output-bytes))
        (stderr-ob (open-output-bytes))
        (stdin-ib  (open-input-bytes #"")))
    (let* ((exit-code    (parameterize ((current-output-port stdout-ob)
                                        (current-error-port  stderr-ob)
                                        (current-input-port  stdin-ib))
                           (apply (if sudo?
                                      system*/exit-code/sudo
                                      system*/exit-code)
                                  command
                                  args)))
           (stdout-bytes (get-output-bytes stdout-ob))
           (stderr-bytes (get-output-bytes stderr-ob)))
      (if (zero? exit-code)
          (if (equal? #"" stderr-bytes)
              stdout-bytes
              (error error-name
                     "command ~S had stderr output (exit-code ~S, stderr ~S, stdout ~S)"
                     (cons command args)
                     exit-code
                     stderr-bytes
                     stdout-bytes))
          (error error-name
                 "command ~S had non-zero exit code (exit-code ~S, stderr ~S, stdout ~S)"
                 (cons command args)
                 exit-code
                 stderr-bytes
                 stdout-bytes)))))

;;-----------------------------------------------------------------------------

(define (get-debian-package-version package-name-string)
  (let ((stdout-bstr (system-command-with-stdout-bytes
                      #:command "/usr/bin/dpkg"
                      #:args    (list "-s" package-name-string))))
    (log-debug (format "!!! ~S" stdout-bstr))
    (cond ((regexp-match #rx#"(?:^|\n)Version:[ \t]*([^ \t\r\n]+)" stdout-bstr)
           => (lambda (m)
                (bytes->string/latin-1 (cadr m))))
          (else #f))))

;;------------------------------------------------------- Disc Device Utilities

(define (eject-device path)
  (let ((path (cleanse-path path)))
    (system-command-with-discarded-output #""
                                          "/usr/bin/eject"
                                          (path->string path))))

(define (uneject-device path)
  (let ((path (cleanse-path path)))
    (system-command-with-discarded-output #""
                                          "/usr/bin/eject"
                                          "-t"
                                          (path->string path))))

;;------------------------------------------------------------------------- VLC

(define the-vlc-sema (make-semaphore 1))
(define the-vlc      #f)

;;----------------------------------------------------------------------- Audio

;; TODO: "abcde -N -d /dev/cdrom"

;;------------------------------------------------------------------------- DVD

(define (get-available-dvd-device-paths)
  (map cdr
       (sort (let ((base-path (string->path "/dev")))
               (let loop ((subpaths (directory-list base-path)))
                 (if (null? subpaths)
                     '()
                     (let* ((subpath (car subpaths))
                            (str     (path->string subpath)))
                       (cond ((regexp-match #rx"dvd([0-9])?$" str)
                              => (lambda (m)
                                   (let ((num-str (cadr m)))
                                     (cons (cons (if num-str
                                                     (string->number num-str)
                                                     0)
                                                 (build-path base-path subpath))
                                           (loop (cdr subpaths))))))
                             (else (loop (cdr subpaths))))))))
             <
             #:key car)))

(define (get-default-dvd-device-path)
  (let ((paths (get-available-dvd-device-paths)))
    (if (null? paths)
        #f
        (car paths))))

(define (get-default-dvd-device-path-string)
  (cond ((get-default-dvd-device-path) => path->string)
        (else #f)))

(define current-dvd-path-string (make-parameter (get-default-dvd-device-path-string)))

;;------------------------------------------------------------- Misc. Utilities

(define rackout-version-string
  (cond ((this-package-version)
         => (lambda (lst)
              (apply (lambda (owner-str name-str major-num minor-num)
                       (if (and (equal? owner-str "neil")
                                (member name-str '("rackout" "rackout.plt")))
                           (format "~A:~A" major-num minor-num)
                           (format "~A/~A:~A:~A" owner-str name-str major-num minor-num)))
                     lst)))
        (else "???")))

;;---------------------------------------------------- Request Handler Dispatch

(define-values (app-dispatch app-url)
  (dispatch-rules
   (()               handle-home) ;; TODO: Make this a redirect.
   (("")             handle-home)
   (("dvd")          handle-dvd)
   (("dvd" "play")   handle-dvd/play)
   (("dvd" "pause")  handle-dvd/pause)
   (("dvd" "stop")   handle-dvd/stop)
   (("dvd" "eject")  handle-dvd/eject)
   (("dvd" "update") handle-dvd/update)
   ;;
   (("dvd" "up") handle-dvd/up)
   (("dvd" "down") handle-dvd/down)
   (("dvd" "left") handle-dvd/left)
   (("dvd" "right") handle-dvd/right)
   (("dvd" "activate") handle-dvd/activate)
   ;;
   (("dvd" "vol-up") handle-dvd/vol-up)
   (("dvd" "vol-down") handle-dvd/vol-down)
   (("dvd" "vol-mute") handle-dvd/vol-mute)
   ;;
   (("dvd" "frame") handle-dvd/frame)
   (("dvd" "slower") handle-dvd/slower)
   (("dvd" "faster") handle-dvd/faster)
   ;;
   (("dvd" "title-next")   handle-dvd/title-next)
   (("dvd" "chapter-next") handle-dvd/chapter-next)
   (("dvd" "title-prev")   handle-dvd/title-prev)
   (("dvd" "chapter-prev") handle-dvd/chapter-prev)
   ;;
   (("dvd" "disc-menu") handle-dvd/disc-menu)
   ;;
   (("audio") handle-audio)
   ;;
   (("about") handle-about)
   ;;
   (("off")          handle-off)
   ;; (("main")         handle-main)
   ))

(provide/contract (start (-> request? response?)))
(define (start req)
  (app-dispatch req))

;;---------------------------------------------------------- Response Utilities

(define-for-syntax (translate-heading-stx heading-stx)
  (if (syntax->datum heading-stx)
      heading-stx
      (datum->syntax heading-stx
                     "RackOut"
                     heading-stx)))

(define-syntax (rackout-pages-response stx)
  (syntax-case stx (page)
    ((_ #:head  (HEADn ...)
        #:pages (KIND #:id      ID
                      #:heading HEADING
                      #:body    BODYn ...) ...)
     #`(response/html-template
        (html (head (title "RackOut")
                    (meta (@ (name    "viewport")
                             (content "width=device-width, initial-scale=1")))
                    (link (@ (rel "stylesheet")
                             (href "/jquery.mobile-"
                                   (% jquery-mobile-version)
                                   "/jquery.mobile-"
                                   (% jquery-mobile-version)
                                   ".min.css")))
                    (link (@ (rel "stylesheet")
                             (href "/rackout.css")))
                    (script (@ (src "/jquery-"
                                    (% jquery-version)
                                    ".min.js")))
                    (script (@ (src "/jquery.mobile-"
                                    (% jquery-mobile-version)
                                    "/jquery.mobile-"
                                    (% jquery-mobile-version)
                                    ".min.js")))
                    (script (@ (src "/rackout.js")))
                    HEADn ...)
              (body #,@(map (lambda (kind-stx id-stx heading-stx bodys-stx)
                              (let ((kind (syntax-e kind-stx)))
                                (if (memq kind '(page home-page dialog))
                                    
                                    #`(div (@ (data-role          "page")
                                              (id                 #,id-stx)
                                              (data-theme         "a")
                                              (data-content-theme "a"))
                                           (div (@ (data-role "header"))
                                                (h1 #,(translate-heading-stx heading-stx))
                                                #,@(if (memq kind '(home-page dialog))
                                                       #'()
                                                       #'((a (@ (href "/")) "RackOut"))))
                                           (div (@ (data-role "content"))
                                                #,@bodys-stx)
                                           #,@(if (memq kind '(home-page))
                                                  #'(
                                                     ;;(div (@ (data-role "footer"))
                                                     ;;     (h4 "Version "
                                                     ;;         (% rackout-version-string)))
                                                     )
                                                  #'()))
                                    (raise-syntax-error 'rackout-pages-response
                                                        "invalid page kind"
                                                        kind))))
                            (syntax->list #'(KIND          ...))
                            (syntax->list #'(ID          ...))
                            (syntax->list #'(HEADING     ...))
                            (syntax->list #'((BODYn ...) ...)))))))))

(define-syntax (rackout-page-response stx)
  (syntax-case stx ()
    ((_ #:id      ID
        #:heading HEADING
        #:head    HEADs
        #:body    BODYn ...)
     #`(rackout-pages-response #:head  HEADs
                               #:pages (page #:id      ID
                                             #:heading HEADING
                                             #:body    BODYn ...)))))

;;------------------------------------------------------------ Request Handlers: Home

(define (handle-home req)
  (rackout-pages-response
   #:head ()
   #:pages
   (home-page
    #:id      "HomePage"
    #:heading #f
    #:body
    (p (a (@ (href "/dvd")   (data-role "button")) "DVD"))
    (p (a (@ (href "/audio") (data-role "button")) "Audio"))
    (p (a (@ (href "/about") (data-role "button")) "About"))
    (p (a (@ (href       "#OffDialog")
             (data-role  "button")
             (data-rel   "dialog")
             ;;(data-icon  "star")
             )
          "Off")))
   (dialog #:id      "OffDialog"
           #:heading "Off"
           #:body
           (p (a (@ (href       "/off")
                    (data-role  "button")
                    (data-icon  "star"))
                 "Yes, Off"))
           (p (a (@ (href       "#")
                    (data-rel   "back")
                    (data-role  "button")
                    (data-icon  "star"))
                 "No, Back to Home")))))

;;------------------------------------------------------------ Request Handlers: About

(define (handle-about req)
  (rackout-page-response
   #:id      "AboutPage"
   #:heading "About"
   #:head    ()
   #:body
   
   ;; TODO: Add RackOut Live timestamp from "/rackout-live-timestamp".
   
   (div (@ (data-role  "collapsible-set")
           (data-inset "false"))
        
        (div (@ (data-role      "collapsible")
                (data-collapsed "false"))
             
             (h3 "Software")
             (p (b "RackOut")
                " version "
                (% rackout-version-string))
             (p (b "Racket")
                " version "
                (% (version)))
             (p (b "Debian GNU/Linux")
                " version "
                (% (with-handlers ((exn:fail? (lambda (e) "???")))
                     (file->string "/etc/debian_version"))))
             (p (b "Linux")
                " version "
                (% (or (get-linux-version-string)
                       "???")))
             (p (b "X.Org")
                " version "
                (% (get-debian-package-version "xserver-xorg")))
             (p (b "XMonad")
                " version "
                (% (get-debian-package-version "xmonad")))
             (p (b "VideoLan VLC")
                " version "
                (% (get-debian-package-version "vlc")))
             (p (b "Ogg Vorbis")
                " version "
                (% (get-debian-package-version "vorbis-tools")))
             (p (b "jQuery")
                " version "
                (% jquery-version))
             (p (b "jQuery Mobile")
                " version "
                (% jquery-mobile-version))
             (p (i "(Many Racket PLaneT packages.)"))
             
             ;; TODO: !!! various PLaneT packages used.  Maybe get automatically, and sort.
             )
        
        (div (@ (data-role "collapsible"))
             (h3 "Hardware")
             (%xexp (get-devices-about-xexp))
             ;;             (h4 "USB Devices")
             ;;             (pre (% (with-handlers ((exn:fail? (lambda (e) "???")))
             ;;                       (bytes->string/latin-1
             ;;                        (system-command-with-stdout-bytes
             ;;                         #:command "/usr/bin/lsusb")))))
             ;;            
             )
        
        (div (@ (data-role "collapsible"))
             (h3 "Legal")
             (p (%xexp (cond ((get-legal-info-from-inforkt)
                              => (lambda (legal-info-string)
                                   legal-info-string))
                             (else "???"))))))))



;;------------------------------------------------------------ Request Handlers: Audio

(define (handle-audio req)
  (rackout-page-response
   #:id      "AudioPage"
   #:heading "Audio"
   #:head    ()
   #:body
   (p (@ (class "Readout"))
      "Playing: "
      (b (span (@ (id "AudioPlayingSpan")))))
   (p "!!!")))

;;------------------------------------------------------------ Request Handlers: Home

(define (handle-dvd req)
  (rackout-page-response
   #:id      "DvdPage"
   #:heading "DVD"
   #:head    ()
   #:body
   ;; Note: This JavaScript must be here, rather than in the HTML "head".
   (script (@ (type "text/javascript"))
           (%verbatim (string-append
                       "$('#DvdPage').bind('pageinit', function() {\n"
                       "  DvdPageInit();\n"
                       "});\n")))
   (p (@ (class "Readout"))
      "Title: "
      (b (span (@ (id "DvdTitleSpan")))))
   (p (@ (class "Readout"))
      "State: "
      (b (span (@ (id "DvdStateSpan"))))
      " "
      (& nbsp)
      " Time: "
      (b (span (@ (id "DvdTimeSpan")))))
   (div (@ (class "ui-grid-a"))
        (div (@ (class "ui-block-a"))
             (a (@ (href "#") (onclick "DvdPlay()")  (data-role "button")) "Play"))
        (div (@ (class "ui-block-b"))
             (a (@ (href "#") (onclick "DvdPause()") (data-role "button")) "Pause")))
   (div (@ (class "ui-grid-a"))
        (div (@ (class "ui-block-a"))
             (a (@ (href "#") (onclick "DvdStop()")  (data-role "button") (data-mini "true")) "Stop"))
        (div (@ (class "ui-block-b"))
             (a (@ (href "#") (onclick "DvdEject()") (data-role "button") (data-mini "true")) "Eject")))
   (div (@ (class "ui-grid-b"))
        ;;
        (div (@ (class "ui-block-a"))
             (a (@ (href "#") (onclick "DvdDiscMenu()") (data-role "button")) "Menu"))
        (div (@ (class "ui-block-b"))
             )
        (div (@ (class "ui-block-c"))
             (a (@ (href "#") (onclick "DvdVolMute()") (data-role "button")) "Mute"))
        ;;
        (div (@ (class "ui-block-a"))
             (a (@ (href "#") (onclick "DvdTitleNext()") (data-role "button") (data-mini "true")) "Title +"))
        (div (@ (class "ui-block-b"))
             (a (@ (href "#") (onclick "DvdChapterNext()") (data-role "button") (data-mini "true")) "Chapter +"))
        (div (@ (class "ui-block-c"))
             (a (@ (href "#") (onclick "DvdVolUp()")   (data-role "button") (data-mini "true")) "Vol +"))
        ;;
        (div (@ (class "ui-block-a"))
             (a (@ (href "#") (onclick "DvdTitlePrev()") (data-role "button") (data-mini "true")) "Title -"))
        (div (@ (class "ui-block-b"))
             (a (@ (href "#") (onclick "DvdChapterPrev()") (data-role "button") (data-mini "true")) "Chapter -"))
        (div (@ (class "ui-block-c"))
             (a (@ (href "#") (onclick "DvdVolDown()") (data-role "button") (data-mini "true")) "Vol -"))
        ;;
        )
   (div (@ (class "ui-grid-b"))
        ;;
        (div (@ (class "ui-block-a"))
             )
        (div (@ (class "ui-block-b"))
             (a (@ (href "#") (onclick "DvdUp()") (data-role "button") (data-mini "true")) "Up"))
        (div (@ (class "ui-block-c"))
             )
        ;;
        (div (@ (class "ui-block-a"))
             (a (@ (href "#") (onclick "DvdLeft()")     (data-role "button") (data-mini "true")) "Left"))
        (div (@ (class "ui-block-b"))
             (a (@ (href "#") (onclick "DvdActivate()") (data-role "button") (data-mini "true")) "OK"))
        (div (@ (class "ui-block-c"))
             (a (@ (href "#") (onclick "DvdRight()")    (data-role "button") (data-mini "true")) "Right"))
        ;;
        (div (@ (class "ui-block-a"))
             )
        (div (@ (class "ui-block-b"))
             (a (@ (href "#") (onclick "DvdDown()") (data-role "button") (data-mini "true")) "Down"))
        (div (@ (class "ui-block-c"))
             )
        ;;
        )
   (div (@ (class "ui-grid-b"))
        ;;
        (div (@ (class "ui-block-a"))
             (a (@ (href "#") (onclick "DvdFrame()")  (data-role "button") (data-mini "true")) "Frame"))
        (div (@ (class "ui-block-b"))
             (a (@ (href "#") (onclick "DvdSlower()") (data-role "button") (data-mini "true")) "Speed -"))
        (div (@ (class "ui-block-c"))
             (a (@ (href "#") (onclick "DvdFaster()") (data-role "button") (data-mini "true")) "Speed +"))
        ;;
        )))

(define (seconds->colon-time-string seconds)
  (if seconds
      (let ((seconds (inexact->exact (truncate seconds))))
        (if (zero? seconds)
            "0:00:00"
            (let*-values (((minutes seconds) (quotient/remainder seconds 60))
                          ((hours   minutes) (quotient/remainder minutes 60)))
              (string-append (number->string hours)
                             (if (< minutes 10) ":0" ":")
                             (number->string minutes)
                             (if (< seconds 10) ":0" ":")
                             (number->string seconds)))))
      "-:--:--"))

(define (dvd-response #:dvd-error (dvd-error (void))
                      #:dvd-state (dvd-state (void))
                      #:dvd-title (dvd-title (void))
                      #:dvd-time  (dvd-time  (void)))
  (response/full (if (void? dvd-error) 200   500)
                 (if (void? dvd-error) #"OK" #"Internal Server Error")
                 (current-seconds)
                 #"application/json"
                 '()
                 `(#"{"
                   ,@(let loop ((vals       (list dvd-error
                                                  dvd-state
                                                  (if (void? dvd-title)
                                                      dvd-title
                                                      (if dvd-title
                                                          (dvd-title-pretty dvd-title)
                                                          dvd-title))
                                                  (if (void? dvd-time)
                                                      dvd-time
                                                      (seconds->colon-time-string dvd-time))))
                                (labels     '(#"\"dvdError\":"
                                              #"\"dvdState\":"
                                              #"\"dvdTitle\":"
                                              #"\"dvdTime\":"))
                                (preceded? #f))
                       (if (null? vals)
                           '(#"}")
                           (let ((val (car vals)))
                             (if (void? val)
                                 (loop (cdr vals)
                                       (cdr labels)
                                       preceded?)
                                 `(,@(if preceded?
                                         '(#",")
                                         '())
                                   ,(car labels)
                                   ,(jsexpr->bytes val)
                                   ,@(loop (cdr vals)
                                           (cdr labels)
                                           #t)))))))))

(define (handle-dvd/play req)
  (log-debug "handle-dvd/play")
  (call-with-semaphore the-vlc-sema
    (lambda ()
      (let loop ((starts 1))
        (with-handlers* ((exn:fail:vlc:process?
                          (lambda (e)
                            (log-debug (format "handle-dvd/play: handling ~S"
                                               e))
                            ;; TODO: Try to stop VLC (stop logging, kill process).
                            (set! the-vlc #f)
                            (loop starts))))
          (cond (the-vlc
                 (begin (vlc-play #:vlc the-vlc)
                        (dvd-response #:dvd-title (vlc-get-title #:vlc the-vlc)
                                      #:dvd-time  (vlc-get-time  #:vlc the-vlc))))
                ((> starts 0)
                 (log-debug "handle-dvd/play: starting vlc")
                 (cond ((current-dvd-path-string)
                        => (lambda (path-str)
                             (set! the-vlc (parameterize ((current-custodian main-custodian))
                                             (start-vlc "--intf"
                                                        "dummy"
                                                        (string-append "dvd://"
                                                                       path-str))))
                             (loop (- starts 1))))
                       (else (dvd-response #:dvd-error "no device"))))
                (else (dvd-response #:dvd-error "cannot play"))))))))

(define (handle-dvd/pause req)
  (log-debug "*handle-dvd/pause")
  (call-with-semaphore the-vlc-sema
    (lambda ()
      (let loop ()
        (if the-vlc
            (with-handlers* ((exn:fail:vlc:process?
                              (lambda (e)
                                (log-debug (format "handle-dvd/pause: handling ~S"
                                                   e))
                                ;; TODO: Try to stop VLC (stop logging, kill process).
                                (set! the-vlc #f)
                                (loop))))
              (vlc-pause #:vlc the-vlc)
              (dvd-response #:dvd-time (vlc-get-time #:vlc the-vlc)))
            (dvd-response #:dvd-error "not running"))))))

(define (handle-dvd/stop req)
  (log-debug "handle-dvd/stop")
  (call-with-semaphore the-vlc-sema
    (lambda ()
      (and the-vlc
           (begin (with-handlers* ((exn:fail:vlc:process?
                                    (lambda (e)
                                      (log-debug (format "handle-dvd/stop: handling ~S"
                                                         e))
                                      ;; TODO: Try to stop VLC (stop logging, kill process).
                                      (set! the-vlc #f))))
                    (vlc-shutdown #:vlc the-vlc))
                  (set! the-vlc #f)))))
  (dvd-response #:dvd-state "stopped" #:dvd-title "" #:dvd-time #f))

(define (handle-dvd/eject req)
  (log-debug "handle-dvd/eject")
  (call-with-semaphore the-vlc-sema
    (lambda ()
      (and the-vlc
           (begin (with-handlers* ((exn:fail:vlc:process?
                                    (lambda (e)
                                      (log-debug (format "handle-dvd/eject: handling ~S"
                                                         e))
                                      ;; TODO: Try to stop VLC (stop logging, kill process).
                                      (set! the-vlc #f))))
                    (vlc-shutdown #:vlc the-vlc))
                  (set! the-vlc #f)))
      ;; TODO: Make a dvd-vlc-device variable protected by dvd-vlc-sema, rather
      ;; than using current-dvd-path-string for this?  Or maybe different way,
      ;; since we'll now use the-vlc for things other than just DVDs.
      (eject-device (current-dvd-path-string))))
  (dvd-response #:dvd-state "stopped"
                #:dvd-title ""
                #:dvd-time  #f))

(define (handle-dvd/update req)
  (log-debug "handle-dvd/update")
  (let-values (((state title time)
                (call-with-semaphore the-vlc-sema
                  (lambda ()
                    (let loop ()
                      (if the-vlc
                          (with-handlers* ((exn:fail:vlc:process?
                                            (lambda (e)
                                              (log-debug (format "handle-dvd/update: handling ~S"
                                                                 e))
                                              ;; TODO: Try to stop VLC (stop logging, kill process).
                                              (set! the-vlc #f)
                                              (loop))))
                            (values (cond ((assoc #"state" (vlc-status #:vlc the-vlc))
                                           => (lambda (pair)
                                                (bytes->string/utf-8 (cdr pair))))
                                          (else "unknown"))
                                    (vlc-get-title #:vlc the-vlc)
                                    (vlc-get-time  #:vlc the-vlc)))
                          (values "stopped"
                                  ""
                                  #f)))))))
    (dvd-response #:dvd-state state
                  #:dvd-title  title
                  #:dvd-time   time)))

(define (handle-off req)
  (rackout-page-response
   #:id      "OffPage"
   #:heading "Off"
   #:head    ()
   #:body
   (ul (@ (data-role   "listview")
          (data-inset  "false")
          (data-filter "false"))
       (li (a (@ (href "#")) "!!!")))))

(define (dumbify-url-string str)
  (cond ((regexp-match #rx"^http://([^/:@]+)(:[0-9]+)?(/.*)?$"
                       str)
         => (lambda (m)
              (apply (lambda (whole addr colonport path)
                       (let ((path (or (if (equal? "/" path)
                                           #f
                                           path)
                                       "")))
                         (if (and colonport (not (equal? colonport ":80")))
                             (string-append addr colonport path)
                             (string-append addr path))))
                     m)))
        (else str)))

(module+ test
  
  (test (dumbify-url-string "http://rackout.lan/")
        "rackout.lan")
  
  (test (dumbify-url-string "http://rackout.lan")
        "rackout.lan")
  
  (test (dumbify-url-string "http://rackout.lan:80/")
        "rackout.lan")
  
  (test (dumbify-url-string "http://rackout.lan:80")
        "rackout.lan")
  
  (test (dumbify-url-string "http://rackout.lan:8000/")
        "rackout.lan:8000")
  
  (test (dumbify-url-string "http://rackout.lan:8000")
        "rackout.lan:8000")
  
  (test (dumbify-url-string "http://rackout.lan:8000/foo")
        "rackout.lan:8000/foo"))

(define (make-dumbified-url hostname port)
  (if (or (not port) (= port 80))
      hostname
      (string-append hostname ":" (number->string port))))

;;(define (handle-main req)
;;  (let ((dumb-main-url (cond ((current-external-base-url-string)
;;                              => dumbify-url-string)
;;                             (else #f))))
;;    (response/html-template
;;     (html (head (title "RackOut")
;;                 (style (@ (type "text/css"))
;;                        "body {"
;;                        "  color: #cccccc;"
;;                        "  background-color: #000000;"
;;                        "  text-align: center;"
;;                        "  font-size: 200%; }"
;;                        ".MainUrlSpan {"
;;                        "  color: #bbffbb;"
;;                        "  font-size: 150%;"
;;                        "  font-family: Courier }" ; !!!
;;                        ".SecondaryUrlSpan {"
;;                        "  color: #bbffbb;"
;;                        "  font-family: Courier }" ; !!!
;;                        ".VerticalCenterOuterDiv {"
;;                        "  text-align: center }"
;;                        ".VerticalCenterOuterDiv:before {"
;;                        "  content: '';"
;;                        "  display: inline-block;"
;;                        "  height: 90%;"
;;                        "  vertical-align: middle;"
;;                        "  margin-right: -0.25em }"
;;                        ".VerticalCenterInnerDiv {"
;;                        "  display: inline-block;"
;;                        "  vertical-align: middle;"
;;                        "  width: 90% }"
;;                        ))
;;           (body (div (@ (class "VerticalCenterOuterDiv"))
;;                      (div (@ (class "VerticalCenterInnerDiv"))
;;                           (h1 "RackOut")
;;                           (%write
;;                            (if dumb-main-url
;;                                (html-template
;;                                 (p "Point your handheld Web browser at:")
;;                                 (p (b (span (@ (class "MainUrlSpan"))
;;                                             (% dumb-main-url)))))
;;                                (html-template
;;                                 (p "Unfortunately, "
;;                                    (code "current-external-base-url-string")
;;                                    " isn't set, so you might not be able to
;;control this RackOut from your handheld Web browser.")))
;;                            (let ((addrs (get-ipv4-addrs)))
;;                              (or (null? addrs)
;;                                  (html-template
;;                                   (p "Or, you can try:")
;;                                   (%write
;;                                    (let* ((port        (current-external-port))
;;                                           (port-suffix (if (or (not port) (= port 80))
;;                                                            #f
;;                                                            (format ":~A" port))))
;;                                      (for-each (lambda (addr)
;;                                                  (html-template
;;                                                   (p (b (span (@ (class "SecondaryUrlSpan"))
;;                                                               (% (if port-suffix
;;                                                                      (string-append addr port-suffix)
;;                                                                      addr)))))))
;;                                                addrs)))))))
;;                           (p (form (@ (action "/")
;;                                       (method "get"))
;;                                    (input (@ (type "submit")
;;                                              (value "Control"))))))))))))

(define-syntax (%vlc:define/provide-keylike-handle-proc stx)
  (syntax-case stx ()
    ((_ PROC-SYM VLC-PROC)
     (let ((proc-str (symbol->string (syntax-e #'PROC-SYM))))
       #`(begin (provide PROC-SYM)
                (define (PROC-SYM req)
                  (log-debug #,proc-str)
                  (call-with-semaphore the-vlc-sema
                    (lambda ()
                      (let loop ()
                        (if the-vlc
                            (begin (with-handlers* ((exn:fail:vlc:process?
                                                     (lambda (e)
                                                       (log-debug (format #,(string-append proc-str
                                                                                           ": handling ~S")
                                                                          e))
                                                       ;; TODO: Try to stop VLC (stop logging, kill process).
                                                       (set! the-vlc #f)
                                                       (loop))))
                                     (VLC-PROC #:vlc the-vlc))
                                   (dvd-response))
                            (dvd-response #:dvd-state "stopped"
                                          #:dvd-title ""
                                          #:dvd-time  #f)))))))))))

(%vlc:define/provide-keylike-handle-proc handle-dvd/up       vlc-key-nav-up)
(%vlc:define/provide-keylike-handle-proc handle-dvd/down     vlc-key-nav-down)
(%vlc:define/provide-keylike-handle-proc handle-dvd/left     vlc-key-nav-left)
(%vlc:define/provide-keylike-handle-proc handle-dvd/right    vlc-key-nav-right)
(%vlc:define/provide-keylike-handle-proc handle-dvd/activate vlc-key-nav-activate)

(%vlc:define/provide-keylike-handle-proc handle-dvd/vol-up   vlc-key-vol-up)
(%vlc:define/provide-keylike-handle-proc handle-dvd/vol-down vlc-key-vol-down)
(%vlc:define/provide-keylike-handle-proc handle-dvd/vol-mute vlc-key-vol-mute)

(%vlc:define/provide-keylike-handle-proc handle-dvd/faster   vlc-key-faster)
(%vlc:define/provide-keylike-handle-proc handle-dvd/slower   vlc-key-slower)

(%vlc:define/provide-keylike-handle-proc handle-dvd/frame    vlc-frame)

(%vlc:define/provide-keylike-handle-proc handle-dvd/title-next   vlc-key-title-next)
(%vlc:define/provide-keylike-handle-proc handle-dvd/chapter-next vlc-key-chapter-next)
(%vlc:define/provide-keylike-handle-proc handle-dvd/title-prev   vlc-key-title-prev)
(%vlc:define/provide-keylike-handle-proc handle-dvd/chapter-prev vlc-key-chapter-prev)

(%vlc:define/provide-keylike-handle-proc handle-dvd/disc-menu vlc-key-disc-menu)

(define-runtime-path static-files-dir-path "static-files")

;;------------------------------------------------------------------ Web Server

(define (run-rackout-web-server)
  (let* ((port-forwarding? (and (current-port-forwarding?)
                                (not (equal? (current-external-port)
                                             (current-internal-port)))))
         (port-unforward-proc
          (and port-forwarding?
               (begin
                 (with-handlers ((exn:fail? (lambda (e)
                                              (log-warning (format "rackout: enabling of port-forwarding failed: ~S"
                                                                   (exn-message e)))
                                              #f)))
                   (system-command-with-discarded-output/sudo #""
                                                              "/sbin/sysctl"
                                                              "-w"
                                                              "net.ipv4.ip_forward=1"))
                 (let* ((add-args (list "/sbin/iptables"
                                        "-t"
                                        "nat"
                                        "-A"
                                        "PREROUTING"
                                        "-p"
                                        "tcp"
                                        "--dport"
                                        (number->string (current-external-port))
                                        "-j"
                                        "REDIRECT"
                                        "--to-port"
                                        (number->string (current-internal-port))))
                        (delete-args (map (lambda (arg)
                                            (if (equal? "-A" arg)
                                                "-D"
                                                arg))
                                          add-args)))
                   (with-handlers ((exn:fail? (lambda (e)
                                                (log-warning (format "rackout: port forwarding add ~S failed: ~S"
                                                                     delete-args
                                                                     (exn-message e)))
                                                #f)))
                     (apply system-command-with-discarded-output/sudo #"" add-args))
                   (lambda ()
                     (with-handlers ((exn:fail? (lambda (e)
                                                  (log-warning (format "rackout: port forwarding removal ~S failed: ~S"
                                                                       delete-args
                                                                       (exn-message e))))))
                       (apply system-command-with-discarded-output/sudo #"" delete-args))))))))
    (dynamic-wind
     void
     (lambda ()
       (serve/servlet start
                      #:launch-browser?   #f
                      #:quit?             #f
                      #:listen-ip         (current-internal-hostname)
                      #:port              (current-internal-port)
                      #:extra-files-paths (list static-files-dir-path)
                      #:servlet-regexp    #rx""))
     (lambda ()
       (and port-forwarding?
            (port-unforward-proc))))))

;;------------------------------------------------------------------------ Main

(define (rackout #:big-display-only? (big-display-only? #false))
  (log-debug (format "LD_LIBRARY_PATH = ~S"
                     (getenv "LD_LIBRARY_PATH")))
  (or (let ((dpy (getenv "DISPLAY")))
        (and dpy (not (equal? "" dpy))))
      (error 'rackout
             "No X \"DISPLAY\" environment variable."))
  (and big-display-only?
       (xrandr-use-big-display-only))
  (create-splash)
  (show-splash)
  (update-splash-lines/urls #f '() #f)
  (log-debug "Starting splash thread...")
  (log-debug "Waiting for network interface(s)...")
  (let* ((ipv4-addrs (let loop ((remaining-seconds 30))
                       (let ((ipv4-addrs (get-ipv4-addrs)))
                         (if (null? ipv4-addrs)
                             (if (> remaining-seconds 0)
                                 (begin (sleep 1)
                                        (loop (- remaining-seconds 1)))
                                 (begin (log-debug "Did not get any network interfaces...")
                                        '()))
                             (begin (log-debug (format "Got network interfaces: ~S"
                                                       ipv4-addrs))
                                    ;; TODO: What if multiple
                                    ;; interfaces, and only one is up
                                    ;; at this time, but another will
                                    ;; be coming up shortly, and we
                                    ;; want to use it?
                                    ipv4-addrs)))))
         (port (current-external-port))
         (alternate-dumb-urls (map (lambda (addr)
                                     (make-dumbified-url addr port))
                                   ipv4-addrs)))
    
    (update-splash-lines/urls #f alternate-dumb-urls #f)
    (log-debug "Starting Web server...")
    (thread run-rackout-web-server)
    (let* ((hostname   (cond ((null? ipv4-addrs) #f)
                             ((dns-find-nameserver)
                              => (lambda (nameserver)
                                   (let loop ((ipv4-addrs ipv4-addrs))
                                     (if (null? ipv4-addrs)
                                         #f
                                         (let* ((addr (car ipv4-addrs)))
                                           (cond ((with-handlers ((exn:fail? (lambda (e)
                                                                               (log-debug (format "DNS reverse-resolve of ~S failed: ~S"
                                                                                                  addr
                                                                                                  (exn-message e)))
                                                                               #f)))
                                                    (dns-get-name nameserver addr))
                                                  => (lambda (hostname)
                                                       (if (regexp-match? #rx"^localhost(?i:\\.*)?$" hostname)
                                                           (loop (cdr ipv4-addrs))
                                                           hostname)))
                                                 (else (loop (cdr ipv4-addrs)))))))))
                             (else #f)))
           (main-dumb-url (if hostname
                              (make-dumbified-url hostname port)
                              #f)))
      (update-splash-lines/urls main-dumb-url alternate-dumb-urls #t)
      (log-debug "Splash thread done.")))
  (void))

;; (lambda ()
;;   !!!!!!!!!!!!!! move this to be called at the right time
;;   (and big-display-only?
;;        (xrandr-use-all-connected-displays-with-panning)))))

;;------------------------------------------------------------------------ Main

;; TODO: Cannot use "module* main" with "raco exe" in Racket 5.3, due to:
;; http://bugs.racket-lang.org/query/?debug=&database=default&cmd=view+audit-trail&cmd=view&pr=13116
;; What about in Racket 5.3.1?

(let ((big-display-only? #false))
  (command-line #:program "rackout"
                #:once-each
                (("-b" "--big-display-only")
                 "!!!"
                 (set! big-display-only? #true)))
  
  (rackout #:big-display-only? big-display-only?))

;;EOF