You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
141 lines
3.5 KiB
141 lines
3.5 KiB
#! /usr/bin/env racket
|
|
#lang racket
|
|
|
|
(require racket/unix-socket)
|
|
(require json)
|
|
|
|
;; Resource management functions
|
|
|
|
(define (bail . args)
|
|
(displayln "/tmp/shelltalk.sock could not be created (may already exist)"
|
|
(current-error-port))
|
|
(exit 1))
|
|
|
|
; All messages come through this socket
|
|
; It is cleaned up after execution finishes
|
|
(define
|
|
control-socket
|
|
(with-handlers ([exn:fail? bail])
|
|
(unix-socket-listen "/tmp/shelltalk.sock")))
|
|
|
|
(define (close-socket in out)
|
|
(close-output-port out)
|
|
(close-input-port in))
|
|
|
|
(define (rm-socket . args)
|
|
; Removes the socket
|
|
(parameterize ([current-error-port
|
|
(open-output-string)])
|
|
|
|
(system "rm /tmp/shelltalk.sock")))
|
|
|
|
|
|
;; Message handling functions
|
|
|
|
(define (write-to entries out)
|
|
(with-handlers ([exn:fail? (const '())])
|
|
(write-json entries out)
|
|
(display "\n" out)))
|
|
|
|
(define (log pid entries)
|
|
(match (thread-receive)
|
|
[(cons 'read out)
|
|
(write-to entries out)
|
|
(log pid entries)]
|
|
|
|
[entry
|
|
(log pid (cons entry entries))]))
|
|
|
|
(define (logger-send loggers pid message)
|
|
(cond
|
|
[(hash-has-key? loggers pid)
|
|
(thread-send (hash-ref loggers pid) message)]
|
|
[else '()]))
|
|
|
|
(define (handle-messages loggers)
|
|
(match (thread-receive)
|
|
[(list 'log pid entry)
|
|
(logger-send loggers pid entry)
|
|
(handle-messages loggers)]
|
|
|
|
[(cons 'spawn pid)
|
|
;; XXX this should check if it exists already
|
|
(handle-messages (hash-set loggers
|
|
pid
|
|
(thread (lambda () (log pid '[])))))]
|
|
|
|
[(cons 'kill pid)
|
|
(kill-thread (hash-ref loggers pid))
|
|
(handle-messages
|
|
(hash-remove loggers pid))]
|
|
|
|
[(cons 'list out)
|
|
(displayln (hash-keys loggers))
|
|
(write-to
|
|
(hash-keys loggers) out)
|
|
(handle-messages loggers)]
|
|
|
|
[(list 'read pid out)
|
|
; Reads all the logs for a given pid
|
|
(logger-send loggers pid (cons 'read out))
|
|
(handle-messages loggers)]))
|
|
|
|
(define message-handler
|
|
(thread (lambda ()
|
|
(handle-messages
|
|
(make-immutable-hash '[])))))
|
|
|
|
(define (handle-connection in out)
|
|
(define input-string (read-line in 'linefeed))
|
|
(cond
|
|
[(eof-object? input-string)
|
|
(close-socket in out)]
|
|
[else
|
|
(match (string-split input-string)
|
|
[(list "spawn" pid)
|
|
(displayln "got spawn")
|
|
(displayln pid)
|
|
(thread-send message-handler (cons 'spawn pid))
|
|
(handle-connection in out)]
|
|
|
|
[(list "read" pid)
|
|
(thread-send message-handler (list 'read pid out))
|
|
(handle-connection in out)]
|
|
|
|
[(list "write" pid message)
|
|
(thread-send message-handler (list 'log pid message))
|
|
(handle-connection in out)]
|
|
|
|
[(list "close" pid)
|
|
(displayln (format "~a closed" pid))
|
|
(thread-send message-handler (cons 'kill pid))
|
|
(close-socket in out)]
|
|
|
|
[(list "list")
|
|
(thread-send message-handler (cons 'list out))]
|
|
|
|
[other
|
|
(displayln other)
|
|
(handle-connection in out)])]))
|
|
|
|
;; Socket handling
|
|
|
|
(define (accept-logs)
|
|
(let-values
|
|
([(in out) (unix-socket-accept control-socket)])
|
|
(thread
|
|
; hands the read capability over for this shell instance
|
|
(lambda ()
|
|
(file-stream-buffer-mode out 'none)
|
|
(handle-connection in out))))
|
|
(accept-logs))
|
|
|
|
; Start execution
|
|
; Use dynamic-wind to ensure socket is always cleaned up
|
|
(dynamic-wind
|
|
(const '())
|
|
(lambda ()
|
|
(with-handlers ([exn:break? rm-socket]
|
|
[exn:fail? rm-socket])
|
|
(accept-logs)))
|
|
rm-socket)
|
|
|