The requested URL was not found on this server.
89 | ") 90 | (403 . " 91 | 92 |The requested URL is forbidden.
96 | ") 97 | (500 . " 98 | 99 |Internal error when handling this request.
103 | ")) 104 | "HTML for various errors.") 105 | 106 | (defun httpd-start () 107 | "Start the emacs web server." 108 | (interactive) 109 | (httpd-stop) 110 | (httpd-clear-log) 111 | (httpd-log-string "'(log)\n") 112 | (httpd-log-alist `(start ,(current-time-string))) 113 | (let 114 | ((proc (make-network-process 115 | :name "httpd" 116 | :service httpd-port 117 | :server t 118 | :family 'ipv4 119 | :filter 'httpd-filter))) 120 | (process-put proc :httpd-root httpd-root) 121 | proc)) 122 | 123 | 124 | (defun httpd-stop () 125 | "Stop the emacs web server." 126 | (interactive) 127 | (if (process-status "httpd") (delete-process "httpd")) 128 | (httpd-log-alist `(stop ,(current-time-string)))) 129 | 130 | (defun httpd-log-string (string) 131 | "Add string to the web server log." 132 | (with-current-buffer (get-buffer-create "*httpd*") 133 | (goto-char (point-max)) 134 | (insert string))) 135 | 136 | (defun httpd-log-alist (item &optional sp) 137 | "Add alist to the log." 138 | (if (not sp) (setq sp 2)) 139 | (with-current-buffer (get-buffer-create "*httpd*") 140 | (goto-char (- (point-max) 2)) 141 | (insert "\n" (make-string sp 32)) 142 | (if (atom (cadr item)) (insert (format "%S" item)) 143 | (insert "(" (symbol-name (car item))) 144 | (dolist (el (cdr item)) 145 | (httpd-log-alist el (+ 1 sp))) 146 | (insert ")")))) 147 | 148 | (defun httpd-clear-log () 149 | "Clear the web server log." 150 | (with-current-buffer (get-buffer-create "*httpd*") 151 | (erase-buffer))) 152 | 153 | (defun httpd-filter (proc string) 154 | "Runs each time client makes a request." 155 | (let* ((httpd-root (process-get proc :httpd-root)) 156 | (log '(connection)) 157 | (req (httpd-parse string)) 158 | (uri (cadr (assoc "GET" req))) 159 | (parsed-uri (httpd-parse-uri uri)) 160 | (uri-path (nth 0 parsed-uri)) 161 | (uri-query (nth 1 parsed-uri)) 162 | (uri-target (nth 2 parsed-uri)) 163 | (servlet (httpd-get-servlet uri-path)) 164 | (path (httpd-gen-path uri-path)) 165 | (status (httpd-status path))) 166 | (setq log (list 'connection 167 | `(date ,(current-time-string)) 168 | `(address ,(car (process-contact proc))) 169 | `(get ,uri-path) 170 | (append '(req) req) 171 | `(servlet ,(format "%S" servlet)) 172 | `(path ,path) 173 | `(status ,status))) 174 | (httpd-log-alist log) 175 | (cond 176 | (servlet (httpd-handle-servlet proc servlet uri-query req uri-path)) 177 | ((not (= status 200)) (httpd-error proc status)) 178 | (t (httpd-send-header proc (httpd-get-mime (httpd-get-ext path)) status) 179 | (httpd-send-file proc path))))) 180 | 181 | (defun httpd-parse (string) 182 | "Parse client http header into alist." 183 | (let* ((lines (split-string string "[\n\r]+")) 184 | (req (list (split-string (car lines))))) 185 | (dolist (line (cdr lines)) 186 | (push (list (car (split-string line ": ")) 187 | (mapconcat 'identity 188 | (cdr (split-string line ": ")) ": ")) req)) 189 | (cddr req))) 190 | 191 | (defun httpd-status (path) 192 | "Determine status code for the path." 193 | (cond 194 | ((not (file-exists-p path)) 404) 195 | ((not (file-readable-p path)) 403) 196 | ((file-directory-p path) 403) 197 | (200))) 198 | 199 | (defun httpd-gen-path (path) 200 | "Translate GET to secure path in httpd-root." 201 | (let ((path (httpd-clean-path (concat httpd-root path)))) 202 | (httpd-htaccess (httpd-path-base path)) 203 | (let ((indexes httpd-indexes) 204 | (testpath nil)) 205 | (if (not (file-directory-p path)) path 206 | (while (not (or (null indexes) 207 | (and testpath (file-exists-p testpath)))) 208 | (setq testpath (concat path "/" (pop indexes)))) 209 | (if (file-exists-p testpath) testpath path))))) 210 | 211 | (defun httpd-path-base (path) 212 | "Return the directory base of the path." 213 | (if (file-directory-p path) path 214 | (let ((pathlist (split-string path "\\/"))) 215 | (mapconcat 'identity (butlast pathlist) "/")))) 216 | 217 | (defun httpd-htaccess (path) 218 | "Load a hypertext access file." 219 | (let ((htaccess (concat path "/" httpd-htaccess-name))) 220 | (if (and (file-exists-p htaccess) (file-readable-p htaccess)) 221 | (load-file htaccess)))) 222 | 223 | (defun httpd-send-file (proc path) 224 | "Serve file to the given client." 225 | (with-temp-buffer 226 | (set-buffer-multibyte nil) 227 | (insert-file-contents path) 228 | (httpd-send-buffer proc (current-buffer)))) 229 | 230 | (defun httpd-clean-path (path) 231 | "Clean dangerous .. from the path." 232 | (mapconcat 'identity 233 | (delete ".." (split-string (url-unhex-string path) "\\/")) "/")) 234 | 235 | (defun httpd-get-ext (path) 236 | "Get extention from path to determine MIME type." 237 | (car (reverse (split-string path "\\.")))) 238 | 239 | (defun httpd-get-mime (ext) 240 | "Fetch MIME type given the file extention." 241 | (cdr (assoc ext httpd-mime-types))) 242 | 243 | (defun httpd-send-header (proc mime status) 244 | "Send header with given MIME type." 245 | (let ((status-str (cdr (assq status httpd-status-codes)))) 246 | (process-send-string 247 | proc (format "HTTP/1.0 %d %s\nContent-Type: %s\n\n" 248 | status status-str mime)))) 249 | 250 | (defun httpd-error (proc status) 251 | "Handle an error situation." 252 | (httpd-send-header proc "text/html" status) 253 | (httpd-send-string proc (cdr (assq status httpd-html)))) 254 | 255 | (defun httpd-send-string (proc string) 256 | "Send string to client." 257 | (process-send-string proc string) 258 | (process-send-eof proc)) 259 | 260 | (defun httpd-send-buffer (proc buffer) 261 | "Send buffer to client." 262 | (with-current-buffer buffer 263 | (httpd-send-string proc (buffer-substring (point-min) 264 | (point-max))))) 265 | 266 | (defun httpd-parse-uri (uri) 267 | "Split a URI into it's components. In the return, the first 268 | element is the script path, the second is an alist of 269 | variable/value pairs, and the third is the target." 270 | (let ((p1 (string-match (regexp-quote "?") uri)) 271 | (p2 (string-match (regexp-quote "#") uri)) 272 | retval) 273 | (push (if p2 (url-unhex-string (substring uri (1+ p2)))) 274 | retval) 275 | (push (if p1 (mapcar #'(lambda (str) 276 | (mapcar 'url-unhex-string (split-string str "="))) 277 | (split-string (substring uri (1+ p1) p2) "&"))) 278 | retval) 279 | (push (substring uri 0 (or p1 p2)) 280 | retval))) 281 | 282 | (defun httpd-get-servlet (uri-path) 283 | "Return function for given path if it exists." 284 | (let ((func (intern-soft (concat "httpd" uri-path)))) 285 | (if (fboundp func) func))) 286 | 287 | (defun httpd-handle-servlet (proc servlet uri-query req uri-path) 288 | "Execute the given servlet and handle any errors." 289 | (with-temp-buffer 290 | (condition-case nil 291 | (let (mimetype) 292 | (setq mimetype (funcall servlet uri-query req uri-path)) 293 | (set-buffer-multibyte nil) 294 | (httpd-send-header proc mimetype 200) 295 | (httpd-send-buffer proc (current-buffer))) 296 | (error (httpd-error proc 500))))) 297 | 298 | (defun httpd-generate-html (sexp) 299 | "Generate HTML from the given sexp. Tags are based on symbol 300 | names, like 'html, 'head. The elisp symbol begins a section of 301 | lisp to be executed, and the results used to generate 302 | HTML. Strings are passed literally." 303 | (let ((tag (if (consp sexp) (car sexp)))) 304 | (cond 305 | ((stringp sexp) 306 | (insert sexp)) 307 | ((eq tag 'elisp) 308 | (mapcar 'httpd-generate-html (eval (cadr sexp)))) 309 | ((symbolp tag) 310 | (insert (format "<%s>\n" tag)) 311 | (mapc 'httpd-generate-html (cdr sexp)) 312 | (insert (format "%s>\n" tag))) 313 | ((listp tag) 314 | (insert (format "<%s " (car tag)) 315 | (mapconcat 316 | #'(lambda (pair) 317 | (format "%s=\"%s\"" (car pair) (cdr pair))) 318 | (cdr tag) " ") ">") 319 | (mapc 'httpd-generate-html (cdr sexp)) 320 | (insert (format "%s>\n" (car tag)))))) 321 | "text/html") 322 | 323 | 324 | ; --------- 325 | ; some file utility functions 326 | ; used by httpd/list-files 327 | 328 | (defun httpd-file-p (dir item) 329 | "Is /dir/item a file?" 330 | (not (file-directory-p (concat dir item)))) 331 | 332 | (defun httpd-last-ch (str) 333 | "Return last char in string" 334 | (aref str (1- (length str))) 335 | ) 336 | 337 | (defun httpd-dir-needs-term-p (dir) 338 | "Does dir path need trailing '/'?" 339 | (not (char-equal ?/ (httpd-last-ch dir))) 340 | ) 341 | 342 | (defun httpd-keep-files (dir dir-list) 343 | "Process dir-list, return list of just files" 344 | (cond 345 | ; end of list signal 346 | ((not dir-list) nil) 347 | 348 | ; if file keep and recurse 349 | ((httpd-file-p dir (car dir-list)) 350 | (cons (car dir-list) (httpd-keep-files dir (cdr dir-list)))) 351 | 352 | ; default - don't keep folders 353 | (t (httpd-keep-files dir (cdr dir-list))) 354 | ) ;end cond scope 355 | ) 356 | 357 | (defun httpd-file-list (dir) 358 | "Return list of files in dir" 359 | (if (httpd-dir-needs-term-p dir) ; add trailing '/' if needed 360 | (setq dir (file-name-as-directory dir))) 361 | 362 | (let ((dir-list (directory-files dir nil nil t))) 363 | (httpd-keep-files dir dir-list) 364 | )) 365 | 366 | 367 | (provide 'httpd) 368 | --------------------------------------------------------------------------------