cl-rw

Layered streams for Common Lisp
git clone https://logand.com/git/cl-rw.git/
Log | Files | Refs

demo-webserver.lisp (9594B)

      1 ;;; Copyright (C) 2015 Tomas Hlavaty <tom@logand.com>
      2 ;;;
      3 ;;; Permission is hereby granted, free of charge, to any person
      4 ;;; obtaining a copy of this software and associated documentation
      5 ;;; files (the "Software"), to deal in the Software without
      6 ;;; restriction, including without limitation the rights to use, copy,
      7 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
      8 ;;; of the Software, and to permit persons to whom the Software is
      9 ;;; furnished to do so, subject to the following conditions:
     10 ;;;
     11 ;;; The above copyright notice and this permission notice shall be
     12 ;;; included in all copies or substantial portions of the Software.
     13 ;;;
     14 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
     15 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
     16 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
     17 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
     18 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
     19 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
     20 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
     21 ;;; DEALINGS IN THE SOFTWARE.
     22 
     23 (defpackage :rw.demo.webserver
     24   (:use :cl))
     25 
     26 (in-package :rw.demo.webserver)
     27 
     28 ;; TODO vhosting
     29 ;; TODO redirect, e.g. www, picowiki
     30 ;; TODO proxy, e.g. ondoc, zappel, counter
     31 ;; TODO logging?
     32 
     33 (defparameter *root* #p"/nix/store/l549rl2lmyk7dvsrv4mrrwgwbswf8q6l-logand-website/share/logandWebsite/data/")
     34 
     35 (defun part-reader (query)
     36   (let ((r (rw:peek-reader (rw:reader (reverse query)))))
     37     (lambda ()
     38       (when (rw:peek r)
     39         (prog1 (let ((x (rw:till r '(#\/))))
     40                  (if x
     41                      (coerce (nreverse x) 'string)
     42                      :nothing))
     43           (rw:skip r '(#\/)))))))
     44 
     45 (defun query-pathname (query default-name default-type)
     46   (let* ((tail (rw:till (rw:peek-reader (part-reader query))))
     47          (head (pop tail)))
     48     (merge-pathnames
     49      (make-pathname :directory (cons :relative (nreverse tail))
     50                     :name (if (eq :nothing head)
     51                               default-name
     52                               (pathname-name head))
     53                     :type (if (eq :nothing head)
     54                               default-type
     55                               (pathname-type head)))
     56      *root*)))
     57 
     58 (defun readable-file-p (pathname)
     59   (let ((f (probe-file pathname)))
     60     (when f
     61       (ignore-errors
     62         (with-open-file (s f :if-does-not-exist nil)
     63           (listen s) ;; dir throws
     64           f)))))
     65 
     66 (defun query-file (query default-name default-type)
     67   (let ((q (rw:till (rw:peek-reader (rw:reader query)) '(#\?))))
     68     (when (every (lambda (c)
     69                    (or (char<= #\A c #\Z)
     70                        (char<= #\a c #\z)
     71                        (char<= #\0 c #\9)
     72                        (member c '(#\/ #\. #\- #\_))))
     73                  q)
     74       (readable-file-p (query-pathname q default-name default-type)))))
     75 
     76 (defun content-type (pathname)
     77   (or (cdr (assoc (pathname-type pathname) rw.http:*mime-types* :test #'equalp))
     78       rw.http:*default-mime-type*))
     79 
     80 (defun serve-file (method query)
     81   (when (member method '(:get :head))
     82     (let ((f (or (query-file query "index" "html")
     83                  #+nil(query-file query "index" "htm")
     84                  #+nil(query-file query "README" nil))))
     85       (when f
     86         `(:http-1.0
     87           :code 200
     88           :headers (("Connection" . "close")
     89                     ("Content-Type" . ,(content-type f)))
     90           :body ,(and (eq :get method) f))))))
     91 
     92 (defun update-headers (old new)
     93   (loop
     94      for x in old
     95      collect (let ((v (cdr (assoc (car x) new :test #'equalp))))
     96                (if v
     97                    (cons (car x) v)
     98                    x))))
     99 
    100 (defun serve-proxy (host port method query protocol headers body)
    101   (or (ignore-errors
    102         (with-open-stream (s (rw.socket:make-tcp-client-socket host port))
    103           (multiple-value-bind (protocol code message headers2 body)
    104               ;; TODO forward upload body
    105               (rw.http::%client1 s host port method protocol query nil ;;TODO split into path query-string
    106                                  (update-headers headers
    107                                                  `(("Host" . ,host))))
    108             (declare (ignore protocol))
    109             ;;(print (list :@@@ headers2))
    110             (list
    111              :http-1.0
    112              :code code
    113              :message message
    114              :headers (flet ((allow (k)
    115                                (let ((x (find k headers2
    116                                               :test #'equalp :key #'car)))
    117                                  (when x
    118                                    (list x)))))
    119                         (append
    120                          '(("Connection" . "close"))
    121                          ;;(allow "Cache-Control")
    122                          ;;(allow "Content-Disposition")
    123                          (allow "Content-Length")
    124                          (allow "Content-Type")
    125                          ;;(allow "Last-Modified")
    126                          (allow "Location")
    127                          (allow "Set-Cookie")))
    128              :body body))))
    129       '(:http-1.0
    130         :code #1=502
    131         :headers (("Connection" . "close")
    132                   ("Content-Type" . "text/plain;charset=UTF-8"))
    133         :body #.(format nil "~a ~a" #1# (cdr (assoc #1# rw.http:*http-codes*))))))
    134 
    135 (defun serve-not-found ()
    136   '(:http-1.0
    137     :code 404
    138     :headers (("Connection" . "close")
    139               ("Content-Type" . "text/plain;charset=UTF-8"))
    140     :body "404 Not Found"))
    141 
    142 (defun parse-host-header (v)
    143   (let ((r (rw:peek-reader (rw:reader v))))
    144     (values (let ((x (rw:till r '(#\:))))
    145               (when x
    146                 (coerce x 'string)))
    147             (progn
    148               (rw:next r)
    149               (rw:next-z0 r)))))
    150 
    151 (defun webserver-handler (msg stream method query protocol headers &optional body)
    152   (declare (ignore stream protocol #+nil body))
    153   (ecase msg
    154     ;;(:read (rw:till (rw:peek-reader stream)))
    155     (:write
    156      (or (multiple-value-bind (host port)
    157              (parse-host-header (cdr (assoc "Host" headers :test #'equalp)))
    158            (cond
    159              ((or (equalp "ondoc.logand.com" host)
    160                   #+nil(equalp "127.0.0.1" host))
    161               ;; proxy_set_header Host $host;
    162               ;; proxy_set_header Gate "$scheme $remote_addr";
    163               (assert (not body))
    164               (serve-proxy "ondoc.logand.com" 1431 method query :http-1.0 headers body))
    165              ;; TODO ?rewrite ondoc.logand.com$ -> http://ondoc.logand.com/$1
    166              ((or (not host)
    167                   (equalp "logand.com" host)
    168                   (equalp "82.192.70.8" host)
    169                   (equalp "localhost" host)
    170                   (equalp "127.0.0.1" host))
    171               ;; TODO redirect ^/pico[wW]iki/ -> http://logand.com/picowiki.html
    172               ;; TODO serve-file-or-directory
    173               (serve-file method query))
    174              ;; TODO ?rewrite .logand.com$ -> http://logand.com/$1
    175              ))
    176          (serve-not-found)))))
    177 
    178 (defun start ()
    179   (rw.http:server (rw.socket:make-ipv4-address "0.0.0.0")
    180                   2341
    181                   'webserver-handler
    182                   :quit (lambda () nil)
    183                   :allowed-methods '(:get :head :post)
    184                   :ignore-errors-p t))
    185 
    186 ;;(start)
    187 
    188 (defun save-image ()
    189   #-(or ccl cmucl sbcl)
    190   (error "TODO RW.DEMO.WEBSERVER::SAVE-IMAGE")
    191   #+clisp
    192   (ext:saveinitmem "cl-rw-demo-webserver"
    193                    :executable t
    194                    :quiet t
    195                    :norc
    196                    :init-function (lambda ()
    197                                     (handler-case
    198                                         (progn
    199                                           (start)
    200                                           (loop (sleep 1)))
    201                                       (condition ()
    202                                         (quit 1)))))
    203   #+ccl ;; TODO no debug on ^C
    204   (ccl:save-application "cl-rw-demo-webserver"
    205                         :prepend-kernel t
    206                         :error-handler :quit-quietly
    207                         :toplevel-function (lambda ()
    208                                              (handler-case
    209                                                  (progn
    210                                                    (start)
    211                                                    (loop (sleep 1)))
    212                                                (condition ()
    213                                                  (ccl:quit 1)))))
    214   #+cmu
    215   (ext:save-lisp "cl-rw-demo-webserver"
    216                  :executable t
    217                  :batch-mode t
    218                  :print-herald nil
    219                  :process-command-line nil
    220                  :load-init-file nil
    221                  :init-function (lambda ()
    222                                   (handler-case
    223                                       (progn
    224                                         (start)
    225                                         (loop (sleep 1)))
    226                                     (condition ()
    227                                       (ext:quit)))))
    228   #+sbcl
    229   (sb-ext:save-lisp-and-die "cl-rw-demo-webserver"
    230                             :executable t
    231                             :toplevel (lambda ()
    232                                         (handler-case
    233                                             (progn
    234                                               (start)
    235                                               (loop (sleep 1)))
    236                                           (condition ()
    237                                             (sb-ext:exit :code 1 :abort t))))))