#lang racket/base
(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")
(require (for-syntax racket/match/parse))
(module+ test
(require "planet-neil-overeasy.rkt"))
(define main-custodian (current-custodian))
(define current-port-forwarding? (make-parameter #t))
(define current-internal-hostname (make-parameter #f))
(define current-internal-port (make-parameter 8000))
(define current-external-port (make-parameter (if (current-port-forwarding?)
80
(current-internal-port))))
(define jquery-version "1.7.1")
(define jquery-mobile-version "1.2.0")
(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)
(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)
(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))))
(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))))
(define the-vlc-sema (make-semaphore 1))
(define the-vlc #f)
(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)))
(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 "???")))
(define-values (app-dispatch app-url)
(dispatch-rules
(() handle-home) (("") 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)
))
(provide/contract (start (-> request? response?)))
(define (start req)
(app-dispatch req))
(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))
#'(
)
#'()))
(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 ...)))))
(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")
)
"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")))))
(define (handle-about req)
(rackout-page-response
#:id "AboutPage"
#:heading "About"
#:head ()
#:body
(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.)"))
)
(div (@ (data-role "collapsible"))
(h3 "Hardware")
(%xexp (get-devices-about-xexp))
)
(div (@ (data-role "collapsible"))
(h3 "Legal")
(p (%xexp (cond ((get-legal-info-from-inforkt)
=> (lambda (legal-info-string)
legal-info-string))
(else "???"))))))))
(define (handle-audio req)
(rackout-page-response
#:id "AudioPage"
#:heading "Audio"
#:head ()
#:body
(p (@ (class "Readout"))
"Playing: "
(b (span (@ (id "AudioPlayingSpan")))))
(p "!!!")))
(define (handle-dvd req)
(rackout-page-response
#:id "DvdPage"
#:heading "DVD"
#:head ()
#:body
(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))
(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))
(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))
(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))
(set! the-vlc #f))))
(vlc-shutdown #:vlc the-vlc))
(set! the-vlc #f)))
(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))
(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-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))
(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")
(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))))))
(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))
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))
(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?))
![[logo]](/logo.png){kind=logo}