Otherwise said, I want to rely on epoll (or similar) to write asynchronous network code that looks like regular code that is without relying on callbacks.
The code must look like synchronous code but unlike synchronous code instead of blocking to wait for network io, it must suspend the current coroutine and restart it when the file descriptor is ready.
My initial thought to achieve that was relying on generators and yield. But this was a mistake that was partly mis-guided by the fact that python used to abuse yield from.
Anyway, guile fibers was a great insipiration and I adapted it to chez scheme.
Here is an example server code:
(define (handler request port)
(values 200 #f (http-get "https://httpbin.davecheney.com/ip")))
(untangle (lambda ()
(run-server "127.0.0.1" 8888)))
The handler returns its IP according the httpbin service. The code look synchronous with the help of call/cc actually call/1cc.
untangle will initiate the event loop with a lambda passed as argument!
Here is the definition of run-server:
(define (run-server ip port handler)
(log 'info "HTTP server running at ~a:~a" ip port)
(let* ((sock (socket 'inet 'stream 'ipv4)))
(socket:setsockopt sock 1 2 1) ;; re-use address
(socket:bind sock (make-address ip port))
(socket:listen sock 1024)
(let loop ()
(let ((client (accept sock)))
(let ((port (fd->port client)))
(spawn (lambda () (run-once handler port)))
(loop))))))
As you can see there is no callback. The only thing that is somewhat different from simple synchronous webserver is the spawn procedure that will handle the request in its own coroutine. In particular accept is asynchronous.
run-once will just pass the scheme request to handler and take its 3 values to build the response. Not very interesting. The part that looks synchronous, but is actually asynchronous is http-get above.
I will only explain, how accept works, given http-get requires to introduce custom binary ports, but suffice to say it is the same behavior...
(define (accept fd)
(let ((out (socket:%accept fd 0 0)))
(if (= out -1)
(let ((code (socket:errno)))
(if (= code EWOULDBLOCK)
(begin
(abort-to-prompt fd 'read)
(accept fd))
(error 'accept (socket:strerror code))))
out)))
As you can see it calls a procedure abort-to-prompt that we could call simply pause that will "stop" the coroutine and call the prompt handler.
abort-to-prompt works in cooperation with call-with-prompt.
Since chez scheme doesn't have prompts I emulate it using two one shot continuations call/1cc
(define %prompt #f)
(define %abort (list 'abort))
(define (call-with-prompt thunk handler)
(call-with-values (lambda ()
(call/1cc
(lambda (k)
(set! %prompt k)
(thunk))))
(lambda out
(cond
((and (pair? out) (eq? (car out) %abort))
(apply handler (cdr out)))
(else (apply values out))))))
(define (abort-to-prompt . args)
(call/1cc
(lambda (k)
(let ((prompt %prompt))
(set! %prompt #f)
(apply prompt (cons %abort (cons k args)))))))
call-with-prompt will initiate a continuation a set! global called %prompt which means there is single prompt for THUNK. If the continuation arguments OUT, the second lambda of call-with-values, starts with the unique object %abort it means the continuation was reached via abort-to-prompt. It will call the HANDLER with the abort-to-prompt continuation and any argument passed to call-with-prompt continuation parameter that is the (apply handler (cons k (cdr out))).
abort-to-promp will initiate a new continuation to be able to come back, after the code executes the prompt's continuation stored in %prompt.
The call-with-prompt is at the heart of the event-loop. Here is it, in two pieces:
(define (exec epoll thunk waiting)
(call-with-prompt
thunk
(lambda (k fd mode) ;; k is abort-to-prompt continuation that
;; will allow to restart the coroutine
;; add fd to the correct epoll set
(case mode
((write) (epoll-wait-write epoll fd))
((read) (epoll-wait-read epoll fd))
(else (error 'untangle "mode not supported" mode)))
(scheme:hash-table-set! waiting fd (make-event k mode)))))
(define (event-loop-run-once epoll waiting)
;; execute every callback waiting in queue,
;; call the above exec procedure
(let loop ()
(unless (null? %queue)
;; XXX: This is done like that because, exec might spawn
;; new coroutine, so we need to cut %queue right now.
(let ((head (car %queue))
(tail (cdr %queue)))
(set! %queue tail)
(exec epoll head waiting)
(loop))))
;; wait for ONE event
(let ((fd (epoll-wait-one epoll (inf))
(let ((event (scheme:hash-table-ref waiting fd)))
;; the event is / will be processed, no need to keep around
(scheme:hash-table-delete! waiting fd)
(case (event-mode event)
((write) (epoll-ctl epoll 2 fd (make-epoll-event-out fd)))
((read) (epoll-ctl epoll 2 fd (make-epoll-event-in fd))))
;; here it will schedule the event continuation that is the
;; abort-to-prompt continuation that will be executed by the
;; next call the above event loop event-loop-run-once
(spawn (event-continuation event))))))
I think that is all.
If you are using chez-scheme, there is chez-a-sync. It uses POSIX poll rather than epoll (epoll is linux specific). guile-a-sync2 is also available for guile-2.2/3.0.
Related
I'm relatively new to Common Lisp (SBCL) and Hunchentoot (using Quicklisp). Can someone tell me how I can get this to work? I'm trying to wrap an Hunchentoot server and some paths in a function as a unit. When I run this, only Hunchentoot's index page is available, the paths /a and /b aren't.
(defun app0 (port)
(let ((*dispatch-table* nil) (server (make-instance 'hunchentoot:acceptor :port port)))
(push (hunchentoot:create-prefix-dispatcher "/a" (lambda () "a")) *dispatch-table*)
(push (hunchentoot:create-prefix-dispatcher "/b" (lambda () "b")) *dispatch-table*)
(hunchentoot:start server) server))
There are multiple problems, as far as I can see. First, request handling via *dispatch-table* requires, that the acceptor is of type easy-acceptor, i.e., you will have to
(make-instance 'easy-acceptor ...)
The documentation has the details.
The second problem is, that you rebind the *dispatch-table* during the set-up code, and push new values into this binding. Since the binding is reverted after the let is finished (and since hunchentoot:start works asynchronously), your entries in the *dispatch-table* are effectively lost, when the server is running. Try
(push (hunchentoot:create-prefix-dispatcher "/a" (lambda () "a")) *dispatch-table*)
(push (hunchentoot:create-prefix-dispatcher "/b" (lambda () "b")) *dispatch-table*)
at the top-level (or do something like that in a dedicated set-up function). If you don't like the global *dispatch-table* approach, you can also create a subclass of acceptor, and override acceptor-dispatch-request (and thus, implement any kind of dispatch you like).
Just as a side-note: you do not prefix *dispatch-table*, while you prefix virtually any other symbol from hunchentoot's package. Is this just a copy/paste mistake, or is this also the case in your actual code? If you do not :use the hunchentoot package in wherever package your code happens to live, then you'd also have to qualify the dispatch table as hunchentoot:*dispatch-table*.
Edit (to address the question in the comment section) There is an example in the hunchentoot documentation, which seems to do exactly what you want to do:
(defclass vhost (tbnl:acceptor)
((dispatch-table
:initform '()
:accessor dispatch-table
:documentation "List of dispatch functions"))
(:default-initargs
:address "127.0.0.1"))
(defmethod tbnl:acceptor-dispatch-request ((vhost vhost) request)
(mapc (lambda (dispatcher)
(let ((handler (funcall dispatcher request)))
(when handler
(return-from tbnl:acceptor-dispatch-request (funcall handler)))))
(dispatch-table vhost))
(call-next-method))
(defvar vhost1 (make-instance 'vhost :port 50001))
(defvar vhost2 (make-instance 'vhost :port 50002))
(push
(tbnl:create-prefix-dispatcher "/foo" 'foo1)
(dispatch-table vhost1))
(push
(tbnl:create-prefix-dispatcher "/foo" 'foo2)
(dispatch-table vhost2))
(defun foo1 () "Hello")
(defun foo2 () "Goodbye")
(tbnl:start vhost1)
(tbnl:start vhost2)
(comments present in the documentation removed for brevity). The tbnl is a predefined nickname for package hunchentoot. You can use both interchangeably, though I would recommend, that you pick one and stick to it. Mixing both might generate confusion.
I have a server running Hunchentoot (CentOS and SBCL). When a user submits a specific type of post request, a subprocess is launched (run-program) which can take up to four minutes to complete. If five people perform that specific type of request at the same time, the server runs out of memory and all of the subprocesses break. What technique do you recommend for queueing up the processes and running them one at a time?
You could set up a single worker thread which receives instructions from a message queue. I have used chanl in the past for similar things, but there are several other options.
(defvar *worker-queue* '())
(defvar *worker-queue-mutex* (sb-thread:make-mutex :name "worker-queue-lock"))
(defvar *worker-queue-semaphore* (sb-thread:make-semaphore :name "worker-queue-semaphore" :count 0))
(defvar *worker-thread*)
(defun worker-queue-function ()
(sb-thread:with-mutex (*worker-queue-mutex*)
(let ((popped-worker-queue-item (pop *worker-queue*)))
(do-something-with popped-worker-queue-item))))
(defun make-worker-thread ()
(setq *worker-thread* (sb-thread:make-thread (lambda ()
(loop
(sb-thread:wait-on-semaphore *worker-queue-semaphore*)
(worker-queue-function)))
:name "worker-thread")))
(defun add-item-to-worker-queue (item-to-add-to-worker-queue)
(sb-thread:with-mutex (*worker-queue-mutex*)
(setq *worker-queue* (append *worker-queue* (list item-to-add-to-worker-queue)))
(sb-thread:signal-semaphore *worker-queue-semaphore*))))
I'm currently designing a program in which part of the program files run on a Raspberry Pi and the other part runs on my computer.
To communicate between them I send messages over TCP/IP.
So to read incoming messages, I use (read port). Then I do some calculations and send the answer back.
Now I noticed that when the answer is a number I don't receive that answer on the other side (I don't know if it is because it's a number or not, I assume it is). Although it has been sent. And afterwards it causes incorrect reads (I suppose because it's still in the buffer).
So this is how I send messages :
#lang racket
; Not important
(require (rename-in racket/tcp
(tcp-connect racket-tcp-connect)
(tcp-listen racket-tcp-listen)))
(define (tcp-connect adress port)
(let-values ([(port-in port-out) (racket-tcp-connect adress port)])
(cons port-in port-out)))
;;;;
(define ports (tcp-connect "localhost" 6667))
(define in (car ports))
(define out (cdr ports))
(define (send destination message expectAnswer? . arguments)
(write-byte destination out) ; Send the destination (is a number < 256) (so that I know on the other side which object I have to send the message to).
(newline out) ; I noticed that if I don't do this, sometimes the message won't be sent.
(write message out)
(newline out)
(write arguments out)
(newline out)
(write expectAnswer? out)
(newline out)
(flush-output out)
(display "destination : ") (display destination) (newline)
(display "Message : ") (display message) (newline)
(display "Arguments : ") (display arguments) (newline)
(display "Expects an answer? ") (display expectAnswer?) (newline)
(when expectAnswer?
(let ((answer (read in)))
(if (eof-object? answer)
'CC ; CC = Connection Closed
(begin (display "Answer : ")(display answer)(newline)(newline)
answer)))))
And this is how I read incoming messages (on the Raspberry Pi) and send an answer back :
#lang racket
; Not important
(require (rename-in racket/tcp
(tcp-listen racket-tcp-listen)
(tcp-accept racket-tcp-accept)))
(define (tcp-accept port)
(let-values ([(port-in port-out) (racket-tcp-accept (racket-tcp-listen port))])
(cons port-in port-out)))
;;;;
(define ports (tcp-accept 6667))
(define in (car ports))
(define out (cdr ports))
(define (executeMessage destination message argumentList expectAnswer?)
(let ((destinationObject (decode destination)) ; This is the object that corresponds to the number we received
(answer '()))
(if (null? argumentList)
(set! answer (destinationObject message))
(set! answer (apply (destinationobject message) argumentList)))
(display "Destination : ")(display destination)(newline)
(display "Message : ")(display message)(newline)
(display "Arguments : ")(display argumentList)(newline)
(display "Expects answer? ")(display expectAnswer?) (newline)
(display "Answer : ")(display answer)(newline)(newline)
; We send the answer back if it is needed.
(when expectAnswer?
(write answer out)
(newline out) ; Because I noticed that if I don't to this, it won't be sent.
(flush-output out))))
; We call this function to skip the newlines that are send "(newline out)"
(define (skipNewline)
(read-byte in))
(define (listenForMessages)
(when (char-ready? in) ; Could be omitted.
; A message was sent
(let ((destination (read-byte in))
(message (begin (skipNewline) (read in)))
(argumentList (begin (skipNewline) (read in)))
(expectAnswer? (begin (skipNewline) (read in))))
(skipNewline)
(executeMessage destination message argumentList expectAnswer?)))
(listenForMessages))
(listenForMessages)
When running the program I see a bunch of messages being sent and answered correctly.
But then I see a message which expects an answer and doesn't get one.
This is what is displayed on the raspberry pi :
Destination : 2
Message : getStationHoogte
Arguments : '()
Expects answer? #t
Answer : 15
So the message was executed and the result was 15 (I checked it and that's the result it was supposed to produce, so I'm happy so far).
Notice that the display of Answer : ... happens just before sending the answer.
But on my computer I read this :
Destination : 2
Message : getStationHoogte
Arguments : ()
Expects answer? #t
Answer :
What I find really really strange is that the answer is nothing?
How is that possible? I use "read" for reading incoming answers, that's a blocking operation. How can it be that it detects an answer (I would suppose 15 in this example) (because it stops blocking) and yet produce "nothing".
What could be the reason of this behaviour? What could be the reason a message (in this case a number) isn't send?
Although I can't tell from what you posted what the exact problem is, I have a couple suggestions:
You can use define-values with the result of tcp-connect, like so:
(define-values (in out) (tcp-connect "localhost" 6667))
It might be simpler and more reliable for each message to be a single write and read. To do so, simply put all the values inside a list (or maybe a #:prefab struct). You can use match to easily extract the elements again. For example something like this (which I haven't run/tested):
(define (send destination message expect-answer? . arguments)
(write (list destination message expect-answer? arguments)
out)
(newline out) ;do you actually need this?
(flush-output out) ;you definitely do want this!
(when expect-answer?
(match (read in)
[(? eof-object?) 'CC] ; CC = Connection Closed
[answer (printf "Answer : ~a\n" answer)])))
(define (listen-for-messages)
(match (read in)
[(? eof-object?) 'CC]
[(list destination message expect-answer? arguments)
(execute-message destination message arguments expect-answer?)
(listen-for-messages)]))
Update about newlines:
Now that you're writeing and reading s-expressions (lists), newlines aren't needed to separate messages -- parentheses now serve that role instead.
What does matter is buffering -- ergo flush-output. And be sure to use it in whatever code runs when expect-answer? is #t, too.
By the way, you can change the buffering mode for some kinds of ports (including TCP ports) with file-stream-buffer-mode. Probably it was 'block by default and that's why you needed newlines, before. It might have worked if you'd changed the mode to 'line, instead. But now that you're using s-expressions I don't think it should matter. You should just use flush-output after each message (or answer) is sent.
Replace (display answer) with (write answer) to see what is printed.
It seems there is NO ANSI standard way to execute an external program and get its output as the following SBCL special code does:
(defmacro with-input-from-program ((stream program program-args environment)
&body body)
"Creates an new process of the specified by PROGRAM using
PROGRAM-ARGS as a list of the arguments to the program. Binds the
stream variable to an input stream from which the output of the
process can be read and executes body as an implicit progn."
#+sbcl
(let ((process (gensym)))
`(let ((,process (sb-ext::run-program ,program
,program-args
:output :stream
:environment ,environment
:wait nil)))
(when ,process
(unwind-protect
(let ((,stream (sb-ext:process-output ,process)))
,#body)
(sb-ext:process-wait ,process)
(sb-ext:process-close ,process))))))
The following CCL code reports "ERROR: value # is not of the expected type (AND CCL::BINARY-STREAM INPUT-STREAM)"
#+clozure
(let ((process (gensym)))
`(let ((,process (ccl:run-program "/bin/sh" (list "-c" (namestring ,program))
:input nil :output :stream :error :stream
:wait nil)))
(when ,process
(unwind-protect
(let ((,stream (ccl::external-process-output-stream ,process)))
,#body)
;(ccl:process-wait (ccl:process-whostate ,process) nil)
(close (ccl::external-process-output-stream ,process))
(close (ccl::external-process-error-stream ,process))))))
I know little CCL. I want to know how i can modify this code to support CCL ?
Any suggestion is appreciated !
Apparently trivial-shell:shell-command doesn't allow exactly what you want (it executes the external command synchronously and returns the whole output).
You could look into CCL's run-program. See:
run-program;
Does there exist standard way to run external program in Common Lisp? (this is a question that is similar to your question);
external-program (suggested in one of the answers in the question above) is supported by Quicklisp and it seems to have better support for executing external programs.
You should use trivial-shell.
Trivial shell is a simple platform independent interface to the underlying Operating System.
I'm attempting to learn a little more about handling sockets and network connections in SBCL; so I wrote a simple wrapper for HTTP. Thus far, it merely makes a stream and performs a request to ultimately get the header data and page content of a website.
Until now, it has worked at somewhat decently. Nothing to brag home about, but it at least worked.
I have come across a strange problem, however; I keep getting "400 Bad Request" errors.
At first, I was somewhat leery about how I was processing the HTTP requests (more or less passing a request string as a function argument), then I made a function that formats a query string with all the parts I need and returns it for use later... but I still get errors.
What's even more odd is that the errors don't happen every time. If I try the script on a page like Google, I get a "200 Ok" return value... but at other times on other sites, I'll get "400 Bad Request".
I'm certain its a problem with my code, but I'll be damned if I know exactly what is causing it.
Here is the code that I am working with:
(use-package :sb-bsd-sockets)
(defun read-buf-nonblock (buffer stream)
(let ((eof (gensym)))
(do ((i 0 (1+ i))
(c (read-char stream nil eof)
(read-char-no-hang stream nil eof)))
((or (>= i (length buffer)) (not c) (eq c eof)) i)
(setf (elt buffer i) c))))
(defun http-connect (host &optional (port 80))
"Create I/O stream to given host on a specified port"
(let ((socket (make-instance 'inet-socket
:type :stream
:protocol :tcp)))
(socket-connect
socket (car (host-ent-addresses (get-host-by-name host))) port)
(let ((stream (socket-make-stream socket
:input t
:output t
:buffering :none)))
stream)))
(defun http-request (stream request &optional (buffer 1024))
"Perform HTTP request on a specified stream"
(format stream "~a~%~%" request )
(let ((data (make-string buffer)))
(setf data (subseq data 0
(read-buf-nonblock data
stream)))
(princ data)
(> (length data) 0)))
(defun request (host request)
"formated HTTP request"
(format nil "~a HTTP/1.0 Host: ~a" request host))
(defun get-page (host &optional (request "GET /"))
"simple demo to get content of a page"
(let ((stream (http-connect host)))
(http-request stream (request host request)))
A few things. First, to your concern about the 400 errors you are getting back, a few possibilities come to mind:
"Host:" isn't actually a valid header field in HTTP/1.0, and depending on how fascist the web server you are contacting is about standards, it would reject this as a bad request based on the protocol you claim to be speaking.
You need a CRLF between your Request-line and each of the header lines.
It is possible that your (request) function is returning something for the Request-URI field -- you substitute in the value of request as the contents of this part of the Request-line -- that is bogus in one way or another (badly escaped characters, etc.). Seeing what it is outputting might help out some.
Some other more general pointer to help you along your way:
(read-buf-nonblock) is very confusing. Where is the symbol 'c' defined? Why is 'eof' (gensym)ed and then not assigned any value? It looks very much like a byte-by-byte copy taken straight out of an imperative program, and plopped into Lisp. It looks like what you have reimplemented here is (read-sequence). Go look here in the Common Lisp Hyperspec, and see if this is what you need. The other half of this is to set your socket you created to be non-blocking. This is pretty easy, even though the SBCL documentation is almost silent on the topic. Use this:
(socket-make-stream socket
:input t
:output t
:buffering :none
:timeout 0)
The last (let) form of (http-connect) isn't necessary. Just evaluate
(socket-make-stream socket
:input t
:output t
:buffering :none)
without the let, and http-connect should still return the right value.
In (http-request)...
Replace:
(format stream "~a~%~%" request )
(let ((data (make-string buffer)))
(setf data (subseq data 0
(read-buf-nonblock data
stream)))
(princ data)
(> (length data) 0)))
with
(format stream "~a~%~%" request )
(let ((data (read-buf-nonblock stream)))
(princ data)
(> (length data) 0)))
and make (read-buf-nonblock) return the string of data, rather that having it assign within the function. So where you have buffer being assigned, create a variable buffer within and then return it. What you are doing is called relying on "side-effects," and tends to produce more errors and harder to find errors. Use it only when you have to, especially in a language that makes it easy not to depend on them.
I mostly like the the way get-page is defined. It feels very much in the functional programming paradigm. However, you should either change the name of the (request) function, or the variable request. Having both in there is confusing.
Yikes, hands hurt. But hopefully this helps. Done typing. :-)
Here's a possibility:
HTTP/1.0 defines the sequence CR LF as the end-of-line marker.
The ~% format directive is generating a #\Newline (LF on most platforms, though see CLHS).
Some sites may be tolerant of the missing CR, others not so much.