120 lines
3.8 KiB
Common Lisp
120 lines
3.8 KiB
Common Lisp
;;;; -*- mode: common-lisp; coding: utf-8; -*-
|
|
|
|
(defpackage ml-survey/app
|
|
(:use #:cl)
|
|
(:export #:extract-from
|
|
#:*html-lang*
|
|
#:generate-uuid
|
|
#:split-uri
|
|
#:today+now
|
|
#:*app*
|
|
#:start
|
|
#:main))
|
|
|
|
(in-package #:ml-survey/app)
|
|
|
|
(defparameter *html-lang* "en")
|
|
|
|
(defparameter *use-cdn* nil)
|
|
|
|
(defparameter *url-key-map*
|
|
'((:survey-id . 1)
|
|
(:lang . 2)
|
|
(:questionnaire . 3)))
|
|
|
|
(defun split-uri (uri)
|
|
(check-type uri string)
|
|
(remove-if #'string-empty-p
|
|
(uiop:split-string uri :separator "/")))
|
|
|
|
(defun extract-from (url key)
|
|
(let* ((parts (split-uri url))
|
|
(index (cdr (assoc key *url-key-map*))))
|
|
(when (and parts index)
|
|
(nth index parts))))
|
|
|
|
(defun today ()
|
|
"Return today's date formatted as ISO-8601."
|
|
(local-time:format-timestring nil
|
|
(local-time:now)
|
|
:format '(:year "-" (:month 2) "-" (:day 2))))
|
|
|
|
(defun now ()
|
|
"Return current time formatted as ISO-8601."
|
|
(local-time:format-timestring nil
|
|
(local-time:now)
|
|
:format '((:hour 2) ":" (:min 2) ":" (:sec 2))))
|
|
|
|
(defun today+now ()
|
|
(format nil "~a ~a" (today) (now)))
|
|
|
|
(defun generate-uuid ()
|
|
(parse-integer (format nil "~A~A~A"
|
|
(sb-posix:getpid)
|
|
(get-universal-time)
|
|
(random 1000000))))
|
|
|
|
(defun generate-random-id (length)
|
|
(let ((charset "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"))
|
|
(coerce (loop repeat length
|
|
collect (char charset (random (length charset))))
|
|
'string)))
|
|
|
|
(defun string-empty-p (string) (= (length string) 0))
|
|
|
|
(defun set-default-directory (directory)
|
|
(setf *default-pathname-defaults* (truename (merge-pathnames directory))))
|
|
|
|
(defun create-server (name port &key address document-root access-log-destination)
|
|
(let ((acceptor (make-instance 'hunchentoot:easy-acceptor
|
|
:address address
|
|
:name name
|
|
:document-root document-root
|
|
:access-log-destination access-log-destination
|
|
:port port)))
|
|
acceptor))
|
|
|
|
(defun start-server (acceptor &key document-root)
|
|
(if document-root
|
|
(setf (hunchentoot:acceptor-document-root acceptor) document-root))
|
|
(hunchentoot:start acceptor))
|
|
|
|
(defun stop-server (acceptor)
|
|
(hunchentoot:stop acceptor))
|
|
|
|
(defun restart-server (acceptor)
|
|
(hunchentoot:stop acceptor)
|
|
(hunchentoot:start acceptor))
|
|
|
|
(defvar *app* (create-server 'app
|
|
8080
|
|
:document-root
|
|
(ml-survey/fileops:public-dir)
|
|
:access-log-destination
|
|
(ml-survey/fileops:access-log-file))
|
|
"The web server.")
|
|
|
|
(defun start ()
|
|
"Start here. Start the web server."
|
|
(start-server *app*))
|
|
|
|
(defun main ()
|
|
"Call this function automatically from binary lisp image. Out of a REPL use
|
|
`start' function."
|
|
(start)
|
|
;; let the webserver run.
|
|
;; warning: hardcoded "hunchentoot".
|
|
;; You can simply run (sleep most-positive-fixnum)
|
|
(handler-case (bt:join-thread (find-if (lambda (th)
|
|
(search "hunchentoot" (bt:thread-name th)))
|
|
(bt:all-threads)))
|
|
;; Catch a user's C-c
|
|
(#+sbcl sb-sys:interactive-interrupt
|
|
#+ccl ccl:interrupt-signal-condition
|
|
#+clisp system::simple-interrupt-condition
|
|
#+ecl ext:interactive-interrupt
|
|
#+allegro excl:interrupt-signal
|
|
() (progn
|
|
(format *error-output* "Aborting.~&")
|
|
(uiop:quit)))
|
|
(error (c) (format t "Woops, an unknown error occured:~&~a~&" c))))
|