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.
Related
Is there any standard way in Common Lisp (+common libraries today) how to put default settings for not-yet-loaded libraries/systems (that are from public sources and cannot be reasonably modified) in the config file such as .sbclrc?
For example, I want to have set
(setf quickproject:*template-directory* "~/projects/template/"
quickproject:*author* "my name <etcetc>")
when Quickproject is loaded. (Obviously, there is an additional complication with the relevant package not being defined at that point of time, but this I can handle.)
Something along the lines of emacs's (with)-eval-after-load.
I am interested primarily in sbcl and quicklisp/asdf libraries, but implementation independent solution is preferred.
I tried to find in existing libraries and out of the box functionalities of SBCL require and of asdf, without success.
I considered and rejected abusing sbcl's extensions on trace.
The best I was able to do so far is define method for asdf:operate, something like (for illustration, not really used)
(defvar *after-system-hooks* (make-hash-table :test 'equal))
(defmethod asdf:operate :after ((op asdf:load-op) (component asdf:system) &key)
(let* ((name (asdf:component-name component)))
(dolist (hook (gethash name *after-system-hooks*))
(funcall hook))
(setf (gethash name *after-system-hooks*) nil)))
(defun intern-uninterned (code package)
(typecase code
(cons (cons (intern-uninterned (car code) package)
(intern-uninterned (cdr code) package)))
(symbol (if (symbol-package code) code (intern (symbol-name code) package)))
(t code)))
(defmacro with-eval-after-load ((name package) &body body)
`(let ((fn (lambda () (eval (intern-uninterned '(progn ,#body) ',package)))))
(if (member ,name (asdf:already-loaded-systems) :test 'equal)
(funcall fn)
(push fn (gethash ,name *after-system-hooks*)))))
and then write something like
(with-eval-after-load ("quickproject" :quickproject)
(setf
#:*template-directory* "~/projects/template/"
#:*author* "My Name <etcetc>"))
However, this is overwriting method on standard component dispatched on standard classes, so it does not seem safe and future-proof. And I do not see how to define new classes to specialize in such a way that it would work with existing systems and tooling.
(And it has eval, but it does not bother me much here)
You are on the right track with asdf:operate. But instead of specializing on asdf:system in general, use EQL Specializer:
(defmethod asdf:operate :after ((op asdf:load-op) (component (eql (asdf:find-system "quickproject"))) &key)
... )
This method only gets called after loading Quickproject.
I would also get rid of extra abstractions and just do want I want to do in the method itself. There is uiop:symbol-call to call a function which isn't loaded yet. But I wouldn't mind using eval with a fixed string.
To use this method (and similar custom forms) from multiple implementations, just put this in a shared-init.lisp file and then load this file in each implementation's init file.
As for common libraries for settings and configs for your own code, I have used https://github.com/Shinmera/ubiquitous before, which worked without any issues.
Thanks to Common Lisp's powerful macro system, I can write lots of code template to generate functions avoid writing redundant code manually. What's more, it can generate different code based on configure file, so I can implement many kinds of feature just apply different configure file.
However, I have no idea how to deliver the project (It's a library):
In my opinion, maybe every config file corresponds to a package?
For example, there is a common lisp file common.lisp, it generate different functions based different configure file in compile-time.
It reads a.conf in compile-time and generate functions for PackageA and reads config b.conf in compile-time for PackageB. But in-place statement must specify only one package, the common.lisp can't both in Package A and B.
By the way, I still can't find out a proper method to get the configure path of project (So I can read and use it in compile-time to generate functions) I have tried *load-truename* for it points to the cache path which contains .fasl file on SBCLv2.0.1. But it looks like the staic files are not contained in it, so it doesn't works.
For macro-expansion the thing you care about is compile time, not load time, and the variables you want are therefore *compile-file-pathname* &/or *compile-file-truename*. ASDF likes to stash compiled files (and hence the files being loaded) somewhere known to it, which you can turn off (I do) but defaultly they end up somewhere far from their sources.
Here's an example macro which should (I have not really tested it) let you enable debugging output on a per-file basis. In real life it would be better to cache the read of the config file/s but this is mildly fiddly to get right.
(declaim (inline mutter))
(defun mutter (format &rest arguments)
(declare (ignore format arguments))
(values))
(defmacro maybe-debugging (&body forms)
(let ((config-file (and *compile-file-truename*
(make-pathname :name "debug"
:type "cf"
:defaults *compile-file-truename*))))
(multiple-value-bind (debugging cond)
(if (and config-file (probe-file config-file))
(ignore-errors
(with-standard-io-syntax
(let ((*read-eval* nil))
(with-open-file (in config-file)
(values (assoc (pathname-name *compile-file-truename*)
(read in)
:test #'string-equal)
nil)))))
(values nil nil))
(when cond
(warn "bogons reading ~A for ~A: ~A"
config-file *compile-file-truename* cond))
(if debugging
`(flet ((mutter (format &rest arguments)
(apply #'format *debug-io* format arguments)))
,#forms)
`(progn
,#forms)))))
For the single-source-file-resulting-in-multiple-object-files you could do something like this (note this repeats a variant of the above code):
(eval-when (:load-toplevel :compile-toplevel :execute)
(defvar *package-compilation-configuration*
nil
"Compile-time configuration for a package")
(defun package-config-value (key &optional (default nil))
(getf *package-compilation-configuration* key default)))
(declaim (inline mutter))
(defun mutter (format &rest args)
(declare (ignore format args))
(values))
(defmacro with-muttering (&body forms)
(if (package-config-value ':mutter)
`(flet ((mutter (fmt &rest args)
(apply #'format *debug-io* fmt args)))
,#forms)
`(progn
,#forms)))
(defun compile-file-for-package (file package &rest kws
&key (output-file nil output-file-p)
&allow-other-keys)
(with-muttering
(let* ((sf-pathname (pathname file))
(package-file (make-pathname :name (string package)
:type "cf"
:defaults sf-pathname))
(the-output-file
(if output-file-p
output-file
(compile-file-pathname
(make-pathname :name (format nil "~A-~A"
(pathname-name sf-pathname)
package)
:defaults sf-pathname))))
(*package-compilation-configuration*
(if (probe-file package-file)
(with-standard-io-syntax
(mutter "~&Compile ~A -> ~A using ~A~%"
sf-pathname the-output-file package-file)
(let ((*read-eval* nil))
(with-open-file (in package-file)
(read in))))
(progn
(mutter "~&Compile ~A -> ~A (no package)~%"
sf-pathname the-output-file)
nil))))
(apply #'compile-file file
:output-file the-output-file
kws))))
Then (compile-file-for-package "x.lisp" "y") will compile x.lisp having read configuration for package "y".
To use something like this in anger you would need to integrate it with ASDF and I don't know how to do that.
An alternative idea is just to use symlinks for the source files, and have the filename-dependent configuration depend on the symlink name, not the target name.
For my case:
project-a.asd:
(asdf:defsystem #:project-a
:components ((:static-file "my-config-file.conf")
(:static-file "common.lisp") ; shared common lisp file
(:file "project-a-package")
(:file "project-a-setup")
;; other components
)
)
project-a-setup.lisp:
(in-package #:project-a)
(eval-when (:compile-toplevel)
(defvar *mypackage* (find-package 'project-a))
(defvar *source-home* (path:dirname *compile-file-truename*))
;; read configure file
(defparameter *myconf*
(with-open-file (stream (merge-pathnames *source-home* #P"my-config-file.conf"))
(read stream)))
)
(load (merge-pathnames *source-home* #P"common.lisp"))
common.lisp:
(let ((*package* *mypackage*))
;; intern symbol
)
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.
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*))))
The following code works but i have to load swank no matter whether i need it or not.
(ql:quickload :swank)
(defun swank ()
(swank:create-server :port 4005 :donot-close t))
If i move "(ql:quickload :swank)" into function swank, then CL will not find package swank.
Sincerely!
Remember that reading is a separate phase in CL. First a form is read, then it is executed. When the reader read the DEFUN form, it didn't recognize the SWANK:CREATE-SERVER symbol because, at that point, QL:QUICKLOAD had not been executed yet. The solution is to use INTERN.
(defun swank ()
(ql:quickload :swank)
(funcall (intern (string '#:create-server) :swank) :port 4005 :dont-close t))