1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
;;; Cruft compatibility layer for dhttp-using code to take advantage
;;; of new features in http-server instead.
;;; Continues to exist solely for my benefit as nobody else ever uses dhttp
(defpackage "DHTTP"
(:use "LISP")
(:shadowing-import-from HTTPSRV
REQUEST similar, not quite the same
; identical
universal-time-to-rfc-date
request-path-info request-stream
request-socket request-body
request-method request-header
request-session html
session-request
body-param
))
(in-package :dhttp)
(defvar *all-servers* (make-hash-table :test #'equal))
(defun export-url (host urlstring &rest args)
(let* ((server (or (gethash host *all-servers*)
(setf (gethash host *all-servers*) (make-server host))))
(url (httpsrv:merge-url (httpsrv:server-base-url server) urlstring)))
(apply #'httpsrv:export-handler url args)))
(defun export-host (hostname)
(let ((server (or (gethash host *all-servers*)
(setf (gethash host *all-servers*) (make-server
host)))))
(httpsrv:export-server server)))
(defun start-server (port-number &optional idle)
(httpsrv:server-start port-number :idle idle))
(defun escape-url (&rest args) (apply #'httpsrv:urlstring-escape args))
(defun redirect (&rest args) (apply #'httpsrv:request-redirect args))
(defun file-request (&rest args) (apply #'httpsrv:file-request-handler args))
(defun send-headers (&rest args) (apply #'httpsrv:request-send-headers args))
(defun request-query-string (request)
(httpsrv:url-query (request-url request)))
;;; httpsrv has url-query-param, but you can't get here from there
(defun query-param (name query-string)
"Assuming QUERY-STRING is made of name=value pairs separated by #\; or #\& ,
find the value of the NAME parameter. Returns nil if not present"
(let ((pairs (mapcar (lambda (x) (split x 2 '(#\=) ))
(split query-string nil '(#\& #\;)))))
(cadr (assoc name pairs :test #'string=))))
(defun url-no-query ((url htplike-url))
(let ((u (httpsrv:copy-url url)))
(setf (httpsrv:url-query u) nil
(httpsrv:url-fragment u) nil)
u))
(defun request-original-minus-query-string (request)
(urlstring (url-no-query (request-original-url request))))
(defun request-minus-query-string (request)
(urlstring (url-no-query (request-url request))))
(defun update-query-param (name value query-string)
"Return a new query string based on QUERY-STRING but with the additional or updated parameter NAME=VALUE"
(let ((pairs (mapcar (lambda (x) (split x 2 '(#\=) ))
(split query-string nil '(#\& #\;)))))
(aif (assoc name pairs :test #'string=)
(rplacd it (list value))
(setf pairs (acons name (list value) pairs)))
(join "&" (mapcar (lambda (x) (s. (car x) "=" (cadr x))) pairs))))
(defun request-url (request) (urlstring (httpsrv:request-url request)))
(defun request-original-url (request)
(httpsrv:urlstring (httpsrv:request-original-url request)))
(defun request-base-url (request)
(urlstring (httpsrv:request-base-url request)))
#|
these were never used externally, as far as I know
parse-body
ip-authenticate
basic-authenticate
make-auth-realm
realm-allows-credentials-p
realm-name
send-file
these can easily be unused
session-request
output-apache-conf
start-debugging-server
|#
|
