98 lines
3.0 KiB
Racket
98 lines
3.0 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/port
|
|
racket/system)
|
|
|
|
(provide windows-tray-available?
|
|
start-windows-tray!)
|
|
|
|
(define (windows-tray-available?)
|
|
(and (eq? (system-type 'os) 'windows)
|
|
(find-executable-path "powershell.exe")
|
|
#t))
|
|
|
|
(define tray-script
|
|
#<<POWERSHELL
|
|
[Console]::OutputEncoding = [System.Text.Encoding]::UTF8
|
|
Add-Type -AssemblyName System.Windows.Forms
|
|
Add-Type -AssemblyName System.Drawing
|
|
|
|
$tray = New-Object System.Windows.Forms.NotifyIcon
|
|
$tray.Icon = [System.Drawing.SystemIcons]::Application
|
|
$tray.Text = "RKT Web Player Agent"
|
|
$tray.Visible = $true
|
|
|
|
$menu = New-Object System.Windows.Forms.ContextMenuStrip
|
|
$open = $menu.Items.Add("Open RKT Web Player Agent")
|
|
$quit = $menu.Items.Add("Exit")
|
|
$tray.ContextMenuStrip = $menu
|
|
|
|
$send = {
|
|
param([string]$message)
|
|
[Console]::Out.WriteLine($message)
|
|
[Console]::Out.Flush()
|
|
}
|
|
|
|
$open.add_Click({ & $send "open" })
|
|
$tray.add_DoubleClick({ & $send "open" })
|
|
$quit.add_Click({
|
|
& $send "quit"
|
|
$tray.Visible = $false
|
|
[System.Windows.Forms.Application]::Exit()
|
|
})
|
|
|
|
[System.Windows.Forms.Application]::Run()
|
|
$tray.Visible = $false
|
|
$tray.Dispose()
|
|
POWERSHELL
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Add a Windows notification-area icon with open and quit actions.
|
|
; pre : Called on Windows with PowerShell and a GUI eventspace available.
|
|
; post : Callbacks are delivered from a reader thread; the stop thunk removes
|
|
; the helper process and its icon.
|
|
; result : A stop thunk, or #f when the platform has no supported tray helper.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (start-windows-tray! on-open on-quit)
|
|
(cond
|
|
((not (windows-tray-available?)) #f)
|
|
(else
|
|
(let-values (((process output input error-output)
|
|
(subprocess
|
|
#f #f #f
|
|
(find-executable-path "powershell.exe")
|
|
"-NoLogo"
|
|
"-NoProfile"
|
|
"-NonInteractive"
|
|
"-WindowStyle"
|
|
"Hidden"
|
|
"-STA"
|
|
"-Command"
|
|
tray-script)))
|
|
(close-output-port input)
|
|
(define stopped? #f)
|
|
(define reader
|
|
(thread
|
|
(λ ()
|
|
(let loop ()
|
|
(let ((line (read-line output 'any)))
|
|
(unless (eof-object? line)
|
|
(cond
|
|
((string=? line "open") (on-open))
|
|
((string=? line "quit") (on-quit)))
|
|
(loop)))))))
|
|
(thread
|
|
(λ ()
|
|
;; Drain diagnostics so the helper cannot block on a full pipe.
|
|
(copy-port error-output (open-output-nowhere))))
|
|
(λ ()
|
|
(unless stopped?
|
|
(set! stopped? #t)
|
|
(when (and reader (not (thread-dead? reader)))
|
|
(kill-thread reader))
|
|
(close-input-port output)
|
|
(close-input-port error-output)
|
|
(when (eq? (subprocess-status process) 'running)
|
|
(subprocess-kill process #t))))))))
|