-
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathelnode.el
3895 lines (3275 loc) · 136 KB
/
elnode.el
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
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; elnode.el --- a simple emacs async HTTP server -*- lexical-binding: t -*-
;; Copyright (C) 2010, 2011, 2012 Nic Ferrier
;; Copyright (C) 2019 GitHub user "Jcaw"
;; Author: Nic Ferrier <[email protected]>
;; Maintainer: GitHub user "Jcaw"
;; Created: 5th October 2010
;; Keywords: lisp, http, hypermedia
;; This file is NOT part of GNU Emacs.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Source code
;;
;; elnode's code can be found here:
;; http://github.com/jcaw/elnode
;;; Style note
;;
;; This codes uses the Emacs style of:
;;
;; elnode--private-function
;;
;; for private functions.
;;; Commentary:
;;
;; This is an elisp version of the popular node.js asynchronous
;; webserver toolkit.
;;
;; You can define HTTP request handlers and start an HTTP server
;; attached to the handler. Many HTTP servers can be started, each
;; must have its own TCP port. Handlers can defer processing with a
;; signal (which allows comet style resource management)
;;
;; See elnode-start for how to start an HTTP server.
;;; Code:
(require 'fakir)
(require 'mm-encode)
(require 'mailcap)
(require 'mail-parse) ; for mail-header-parse-content-type
(require 'url-util)
(require 'kv)
(require 's)
(require 'dash)
(require 'rx)
(require 'web)
(require 'json)
(require 'db)
(require 'dired) ; needed for the setup
(require 'tabulated-list)
(require 'noflet)
(eval-when-compile (require 'cl))
(defconst ELNODE-FORM-DATA-TYPE "application/x-www-form-urlencoded"
"The type of HTTP Form POSTs.")
(defconst http-referrer 'referer
"Helper to bypass idiot spelling of the word `referrer'.")
;; Customization stuff
(defgroup elnode nil
"An extensible asynchronous web server for Emacs."
:group 'applications)
(defvar elnode-server-socket nil
"Where we store the server sockets.
This is an alist of proc->server-process:
(port . process)")
(defcustom elnode-init-port 8000
"The port that `elnode-init' starts the default server on."
:group 'elnode)
(defcustom elnode-init-host "localhost"
"The default host for the default webserver.
Also used as the default host for `elnode-make-webserver'.
See `elnode-init' for more details."
:group 'elnode)
;;;###autoload
(defconst elnode-config-directory
(file-name-as-directory (expand-file-name "elnode" user-emacs-directory))
"The config directory for elnode to store peripheral files.
This is used as a base for other constant directory or file
names (the elnode auth database is a file in this directory, the
elnode webserver has a docroot directory in this directory).
It is based on the `user-emacs-directory' which always seems to
be set, even when emacs is started with -Q.")
(defun elnode/con-lookup (con attr)
"Dynamic lookup."
(gethash attr (car (process-plist con))))
(defmacro elnode/con-put (con attr value &rest other)
"Put ATTR with VALUE into an array on CON's plist.
If OTHER is specified it is other pairs of attribute and value."
(declare (indent 1)
(debug (sexp sexp form &rest sexp)))
(let ((valv (make-symbol "val"))
(conv (make-symbol "con")))
`(let* ((,valv ,value)
(,conv ,con)
(convec
(or (car (process-plist ,conv))
(car (set-process-plist
,conv (list (make-hash-table :test 'eq)))))))
(puthash ,attr ,valv convec)
,@(when other
(loop for (name val) on other by 'cddr
collect `(puthash ,name ,val convec))))))
(defmacro elnode/con-get (con attr)
"Alternative implementation of `process-get'."
(let ((conv (make-symbol "con")))
`(let* ((,conv ,con)
(convec
(or (car (process-plist ,conv))
(car (set-process-plist
,conv (list (make-hash-table :test 'eq)))))))
(gethash ,attr convec))))
(defun elnode/get-server-prop (process key)
"Get the value of the KEY from the server attached to PROCESS.
Server properties are bound with `elnode-start' which sets up
`elnode--log-fn' to ensure that all sockets created have a link
back to the server."
(let* ((server (elnode/con-get process :server)))
(elnode/con-lookup server key)))
;; Error log handling
(defun elnode-join (&rest parts)
"Path join the parts together.
EmacsLisp should really provide this by default."
(let* (savedpart
(path
(loop for p in parts
concat
(when (> (length p) 0)
(setq savedpart p)
(file-name-as-directory p)))))
(if (equal (elt savedpart (- (length savedpart) 1)) ?\/)
path
(substring path 0 (- (length path) 1)))))
(defun elnode--dir-setup (dir default default-file-name
&optional target-file-name
&rest other-files)
"Install a DIR and DEFAULT-FILE-NAME if it's not setup already.
This is a packaging helper. It helps an ELPA package install
files from it's package base into the user's Emacs. If the DIR
is specified under `user-emacs-directory'.
DIR is the directory to install, DEFAULT is the default for that
directory, unless DIR equals DEFAULT nothing is done.
DEFAULT-FILE-NAME is the name of the file that will be installed
in DIR. It is the expected name of the source file inside the
package. Unless TARGET-FILE-NAME is specified it is also the
name the installed file will be given. If the TARGET-FILE-NAME
is specified then that is the the name the file is installed as.
If OTHER-FILES is present it is treated as a list of other
filenames to copy to the DIR."
(when (and
(equal
dir
default)
(not (file-exists-p dir)))
;; Do install
(let ((source-default-file
(concat
(file-name-directory
(or (buffer-file-name)
(symbol-file 'elnode--dir-setup))) ; this not very portable
;; This should probably tie in with the makefile somehow
default-file-name)))
(when (and source-default-file
(file-exists-p source-default-file))
(let ((to (concat
dir
(or target-file-name default-file-name))))
(make-directory dir t)
(message "copying %s elnode wiki default page to %s" dir to)
(dired-copy-file source-default-file to nil)
(when other-files
(noflet ((resolve-filename (file)
(if (file-name-absolute-p file)
file
(concat
(file-name-directory
source-default-file)
file))))
(loop for file in other-files
;; does the file exist?
if (and file (file-exists-p (resolve-filename file)))
do
(dired-copy-file
;; from...
(resolve-filename file)
;; to...nd
(concat dir (file-name-nondirectory file))
nil)))))))))
(defun elnode--protected-load (feature dir)
"Try and require FEATURE, if it fails try and load."
(condition-case err
(require feature)
(file-error (progn
(load
(concat dir (symbol-name feature) ".el"))
(require feature)))))
;;;###autoload
(defmacro elnode-app (dir-var &rest features)
"A macro that sets up the boring boilerplate for Elnode apps.
This sets up lexical binding, captures the module's parent
directory in DIR-VAR, requires `cl' and any other features you
list. Use it like this:
(elnode-app my-app-dir esxml mongo-elnode)
Once used you can access the variable `my-app-dir' as the dirname
of your module (which is useful for serving files and such)."
(declare (indent 1))
(let ((dir-var-v (make-symbol "dv")))
`(let ((,dir-var-v (file-name-directory
(or (buffer-file-name)
load-file-name
default-directory))))
(setq lexical-binding t)
(defconst ,dir-var ,dir-var-v)
(require 'cl)
(require 'elnode)
,@(loop for f in features
collect
`(elnode--protected-load
(quote ,f) ,dir-var-v)))))
(defcustom elnode-log-files-directory nil
"The directory to store any Elnode log files.
If this is not-nil (in which case logs are not saved at all) it
must be the name of a directory Elnode can use for storing logs.
If a directory is specified but it does not exist it is created."
:group 'elnode
:type '(choice (const :tag "Off" nil)
directory))
(defvar elnode-log-buffer-position-written 0
"The position in the log buffer written.
This is used by `elnode-log-buffer-log' to track what has been written
so far.")
(defvar elnode-log-buffer-max-size 1000
"Maximum number of lines of log.")
(defvar elnode-log-buffer-datetime-format "%Y-%m-%dT%H:%M:%S"
"The date time format used by `elnode-log-buffer-log'.")
(defun elnode-log-buffer-log (text buffer-or-name &optional filename)
"Log TEXT to the BUFFER-OR-NAME saving the buffer in FILENAME.
BUFFER-OR-NAME is either a buffer or a string naming a buffer.
FILENAME is a filename to save the buffer into. If the FILENAME
is not specified then we try to use the filename of the
BUFFER-OR-NAME.
If neither a buffer filename nor FILENAME is specified then an
error is generated.
The TEXT is logged with the current date and time formatted with
`elnode-log-buffer-datetime-format'."
(let ((name (or filename (buffer-file-name (get-buffer buffer-or-name)))))
(with-current-buffer (get-buffer-create buffer-or-name)
(let ((buffer-read-only nil))
(unless (assq
'elnode-log-buffer-position-written
(buffer-local-variables))
(make-local-variable 'elnode-log-buffer-position-written)
(setq elnode-log-buffer-position-written (make-marker))
(set-marker elnode-log-buffer-position-written (point-min)))
;; To test this stuff we could rip these functions out into
;; separate pieces?
(save-excursion
(goto-char (point-max))
(insert
(format
"%s: %s\n"
(format-time-string elnode-log-buffer-datetime-format)
text))
;; Save the file if we have a filename
(when name
(if (not (file-exists-p (file-name-directory name)))
(make-directory (file-name-directory name) t))
;; could be switched to write-region - probably better
(append-to-file elnode-log-buffer-position-written (point-max) name)
(set-marker elnode-log-buffer-position-written (point-max)))
;; Truncate the file if it's grown too large
(goto-char (point-max))
(forward-line (- elnode-log-buffer-max-size))
(beginning-of-line)
(delete-region (point-min) (point)))))))
(defcustom elnode-error-log-to-messages t
"Whether to send elnode logging through the messaging system."
:group 'elnode
:type '(boolean))
(defvar elnode-server-error-log "*elnode-server-error*"
"The buffer where error log messages are sent.")
(defvar elnode--do-error-logging t
"Allows tests to turn off error logging.")
(defvar elnode--http-send-string-debug nil
"Whether to do error logging in `elnode-http-send-string'.
That is very high logging, probably a bad idea for anyone but an
elnode developer.")
(defun elnode--get-error-log-buffer ()
"Returns the buffer for the error-log."
(get-buffer-create elnode-server-error-log))
(defmacro elnode-error (msg &rest args)
"Log MSG with ARGS as an error.
This function is available for handlers to call. It is also used
by elnode iteslf.
There is only one error log, in the future there may be more."
`(when elnode--do-error-logging
(let ((filename (elnode--log-filename "elnode-error"))
(fmtmsg (format ,msg ,@args)))
(elnode-log-buffer-log
fmtmsg
(elnode--get-error-log-buffer)
filename)
(when elnode-error-log-to-messages
(message "elnode: %s" fmtmsg)))))
(defconst elnode-msg-levels (list :debug :info :status :warning)
"Levels of message `elnode-msg' uses.")
(defmacro elnode--posq (element lst)
"Return the index in the LST of ELEMENT."
(let ((elv (make-symbol "el")))
`(let ((,elv ,element))
(catch :escape
(let ((i 0))
(dolist (e ,lst)
(when (eq e ,elv)
(throw :escape i))
(setq i (+ i 1)))
nil)))))
(defmacro elnode-msg (level msg &rest args)
"Log MSG to the error console with a particular LEVEL.
LEVEL is compared to `elnode--do-error-logging'."
(declare (indent 2))
`(when (or (eq t elnode--do-error-logging)
(>= (elnode--posq ,level elnode-msg-levels)
(elnode--posq
(or elnode--do-error-logging (car elnode-msg-levels))
elnode-msg-levels)))
(elnode-error ,msg ,@args)))
(defun elnode--log-filename (logname)
"Turn LOGNAME into a filename.
`elnode-log-files-directory' is used as the container for log files.
This function mainly exists to make testing easier."
(when elnode-log-files-directory
(expand-file-name
(format "%s/%s"
elnode-log-files-directory
logname))))
(defvar elnode-log-access-format-path-width 20
"How to truncate the path in the access log.")
(defun elnode-log-access-format-func (httpcon)
"Standard access log format function."
(format
(concat
"%s % 8d %s % "
(number-to-string elnode-log-access-format-path-width)
"s %s")
(elnode/con-get httpcon :elnode-httpresponse-status)
(or (elnode/con-get httpcon :elnode-bytes-written) 0)
(elnode-http-method httpcon)
(elnode-http-pathinfo httpcon)
(format-time-string ""
(time-subtract (current-time)
(elnode/con-get httpcon :elnode-http-started)))))
(defcustom elnode-log-access-default-formatter-function
'elnode-log-access-format-func
"The default access log formatter function.
This is used when there is no specific logger function for a
log-name."
:group 'elnode
:type 'function)
(defcustom elnode-log-access-alist nil
"An association list of access log format functions for log names.
An access log format function receives the http connection and
should return a log line to be entered in the log buffer.
These override the default log formatter."
:group 'elnode
:type '(alist
:key-type string
:value-type function))
(defun elnode-log-access (logname httpcon)
"Log the HTTP access in buffer LOGNAME.
This function is available for handlers to call. It is also used
by elnode iteslf."
(let* ((elnode-log-buffer-datetime-format "%Y-%m-%d-%H:%M:%S")
(buffer-name (format "*%s-elnode-access*" logname))
(filename (elnode--log-filename logname))
(formatter
(or
(kva logname elnode-log-access-alist)
elnode-log-access-default-formatter-function))
(formatted
(when formatter
(funcall formatter httpcon))))
(elnode-log-buffer-log formatted buffer-name filename)))
;; Defer stuff
(progn
;; Sets up the elnode defer signal
(put 'elnode-defer
'error-conditions
'(error elnode elnode-defer))
(put 'elnode-defer
'error-message
"Elnode handler processing defered"))
(defvar elnode--deferred '()
"List of deferred pairs: (socket . handler).")
(defun elnode-defer-now (handler)
"The function you call to defer processing of the current socket.
Pass in the current HANDLER.
FIXME: We could capture the current handler somehow? I think the
point is that whatever signals elnode-defer should be getting
control back when the deferred is re-processed."
(signal 'elnode-defer handler))
(defmacro elnode-defer-until (guard &rest body)
"Test GUARD and defer if it fails and BODY if it doesn't.
`httpcon' is captured in this macro which means the macro can
only be expanded where there is an inscope `httpcon'.
Inside the macro the symbol `elnode-defer-guard-it' is bound to
the value of the GUARD."
(declare (indent 1))
(let ((bv (make-symbol "bv"))
(gv (make-symbol "gv"))
(fv (make-symbol "fv")))
`(let* ((,gv (lambda () ,guard))
(elnode-defer-guard-it (funcall ,gv))
(,bv (lambda (httpcon) ,@body))
(,fv ; a y-combinator!
(lambda (httpcon proc)
(setq elnode-defer-guard-it (funcall ,gv))
(if elnode-defer-guard-it
(funcall ,bv httpcon)
;; the test failed we should defer again
(elnode-defer-now
(lambda (http-con)
(funcall proc http-con proc)))))))
(if elnode-defer-guard-it
(funcall ,bv httpcon)
;; The test failed, we should defer.
(elnode-defer-now
(lambda (httpcon) ; apply the y-combinator
(funcall ,fv httpcon ,fv)))))))
(defun elnode--deferred-add (httpcon handler)
"Add the specified HTTPCON/HANDLER pair to the deferred list."
(elnode-msg :info "deferred-add: adding a defer %s for %s" handler httpcon)
(push (cons httpcon handler) elnode--deferred))
(defun elnode--deferred-process-open (httpcon handler)
"Process the HANDLER with the known open HTTPCON."
;; (elnode-error "defer - just before calling the handler %s" handler)
(funcall handler httpcon))
;; Log levels
(defconst elnode-log-debug 0)
(defconst elnode-log-info 1)
(defconst elnode-log-warning 2)
(defconst elnode-log-critical 3)
(defvar elnode-defer-processor-log-level elnode-log-critical
"Log level of the defer processor.")
(defun elnode--deferred-log (level msg &rest args)
"Special log for elnode-deferreds"
(when (>= level elnode-defer-processor-log-level)
(elnode-msg :info (format "elnode-deferred-processor %s %s" msg args))))
(defvar elnode-defer-failure-hook nil
"Hook called when a deferred socket fails.
The hook function is called with the http connection and the
failure state which either the symbol `closed' or the symbol
`failed'.")
(defconst elnode--debug-with-backtraces nil
"Feature switch to include backtrace debugging support.")
(defmacro elnode/case (expr &rest clauses)
"A better `case' implementation."
(declare (indent 1)(debug (form &rest (sexp body))))
(let* ((backwards (reverse clauses))
(last-clause (car backwards))
(other-clauses (cdr backwards))
(else-clause (when (eq t (car last-clause)) last-clause)))
`(catch :escapesym
(let ((value (progn ,expr)))
,@(let (collected)
(dolist (c (if else-clause other-clauses clauses) collected)
(setq collected
(cons `(when (eq ,(car c) value)
(throw :escapesym (progn ,@(cdr c))))
collected))))
,(if else-clause `(throw :escapesym ,@(cdr else-clause)))))))
(defun elnode--deferred-processor ()
"Process the deferred queue."
(let ((run (random 5000)) ; use this to disambiguate runs in the logs
(new-deferred (list)))
(elnode--deferred-log elnode-log-info "start")
(loop for pair in elnode--deferred
do
(let ((httpcon (car pair))
(handler (cdr pair)))
(elnode/case (process-status httpcon)
('open
(elnode--deferred-log elnode-log-info
"open %s %s" httpcon handler)
(condition-case signal-value
(elnode--deferred-process-open httpcon handler)
('elnode-defer
(push
(cons httpcon (cdr signal-value))
new-deferred))
(error
(elnode--deferred-log
elnode-log-critical
"error %s - %s %S" httpcon signal-value
(if elnode--debug-with-backtraces
debugger-previous-backtrace
"")))))
('closed
(elnode--deferred-log elnode-log-info
"closed %s %s" httpcon handler)
;; Call any hook function for defer closes
(loop for hook-func in elnode-defer-failure-hook
do
(funcall hook-func httpcon 'closed)))
('failed
(elnode--deferred-log
elnode-log-info "failed %s %s" httpcon handler)
;; Call any hook function for defer failures
(loop for hook-func in elnode-defer-failure-hook
do
(funcall hook-func httpcon 'failed)))
;; Not sure how to do connect... same as open?
;; ... or just put it back?
('connect
(push
(cons httpcon handler)
new-deferred)))))
(elnode--deferred-log elnode-log-info "complete")
;; Set the correct queue
(setq elnode--deferred new-deferred)))
(defun elnode-deferred-queue-process ()
(interactive)
(elnode--deferred-processor))
(defvar elnode-defer-on nil
"Whether to do deferring or not.")
(defvar elnode--defer-timer nil
"The timer used by the elnode defer processing.
This is initialized by `elnode--init-deferring'.")
(defun elnode--init-deferring ()
"Initialize elnode defer processing.
Necessary for running comet apps."
(setq elnode--defer-timer
(run-at-time "2 sec" 2 'elnode--deferred-processor)))
(defun elnode-deferred-queue-start ()
"Start the deferred queue, unless it's running."
(interactive)
(unless elnode-defer-on
(setq elnode-defer-on t))
(unless elnode--defer-timer
(elnode--init-deferring)))
(defun elnode-deferred-queue-stop ()
"Stop any running deferred queue processor."
(interactive)
(when elnode--defer-timer
(cancel-timer elnode--defer-timer)
(setq elnode--defer-timer nil)))
;;; Basic response mangling
(defcustom elnode-default-response-table
'((201 . "Created")
(301 . "Moved")
(302 . "Found")
(304 . "Not modified")
(400 . "Bad request")
(404 . "Not found")
(500 . "Server error")
(t . "Ok"))
"The status code -> default message mappings.
When Elnode sends a default response these are the text used.
Alter this if you want to change the messages that Elnode sends
with the following functions:
'elnode-send-400'
'elnode-send-404'
'elnode-send-500'
The function `elnode-send-status' also uses these."
:group 'elnode
:type '(alist :key-type integer
:value-type string))
(defconst elnode--default-response-groups
'((1 . "Informing you of something.")
(2 . "Ok.")
(3 . "")
(4 . "Bad.")
(5 . "Error."))
"Response codes for error code / 100.
These are designed to be used when a specific code is not
available.")
(defun elnode--format-response (status &optional msg)
"Format the STATUS and optionally MESSAGE as an HTML return."
(format "<h1>%s</h1>%s\r\n"
(cdr (or (assoc status elnode-default-response-table)
(assoc (/ status 100) elnode--default-response-groups)
(assoc t elnode-default-response-table)))
(if msg (format "<p>%s</p>" msg) "")))
;; Main control functions
(defun elnode--http-parse-header (buffer start &optional non-header)
"Parse a header from the BUFFER at point START.
The initial header may be parsed with this or if NON-HEADER is
sent then another header, such as a multipart header, may be read.
If the complete header has not been read then we throw to
`elnode-parse-http' with either `header' or `non-header'.
We return a list of the leader, which is the first line of the
header (which is not the header) followed by an alist of
headers."
(with-current-buffer buffer
(let ((hdrend (re-search-forward "\r\n\r\n" nil 't)))
(when (not hdrend)
(throw 'elnode-parse-http (or (and non-header 'non-header) 'header)))
(let* ((lines
(split-string
(buffer-substring start hdrend)
"\r\n"
't))
(status (car lines)) ;; the first line is the status line
(header (cdr lines)) ;; the rest of the lines are the header
(header-alist-strings
(mapcar
(lambda (hdrline)
(when (string-match
"\\([A-Za-z0-9_-]+\\):[ ]*\\(.*\\)"
hdrline)
(cons
(downcase (match-string 1 hdrline))
(match-string 2 hdrline))))
header)))
(list status header-alist-strings)))))
(defun elnode--http-parse (process)
"Parse the HTTP header for the PROCESS.
If the request is not fully complete (if the header has not
arrived yet or we don't have all the content-length yet for
example) this can throw `elnode-parse-http'. The thing being
waited for is indicated.
Important side effects of this function are to add certain
process properties to the HTTP connection. These are the result
of successful parsing."
;; FIXME - we don't need to do this - we should check for
;; header-parsed and avoid it we we can
(with-current-buffer (process-buffer process)
(save-excursion
(goto-char (point-min))
(destructuring-bind (leader alist-strings)
(elnode--http-parse-header (current-buffer) (point-min))
(let* ((hdrend (point))
(alist-syms
(kvalist-keys->symbols alist-strings :first-fn 'downcase))
(content-len (assq 'content-length alist-syms)))
;; Check the content if we have it.
(when content-len
(let* ((available-content (- (point-max) hdrend)))
(when (> (string-to-number (cdr content-len))
available-content)
(throw 'elnode-parse-http 'content))))
(elnode/con-put process
:elnode-header-end hdrend
:elnode-http-status leader
:elnode-http-header-syms alist-syms
:elnode-http-header alist-strings)))))
;; Return a symbol to indicate done-ness
'done)
(defun elnode--http-make-hdr (method resource &rest headers)
"Convenience function to make an HTTP header.
METHOD is the method to use. RESOURCE is the path to use.
HEADERS should be pairs of strings indicating the header values:
(elnode--http-make-hdr 'get \"/\" '(host . \"localhost\"))
Where symbols are encountered they are turned into strings.
Inside headers they are capitalized.
A header pair with the key `body' can be used to make a content body:
(elnode--http-make-hdr 'get \"/\" '(body . \"some text\"))
=>
GET / HTTP/1.1
some text
No other transformations are done on the body, no content type
added or content length computed."
(let (body)
(noflet ((header-name (hdr)
(if (symbolp (car hdr))
(symbol-name (car hdr))
(car hdr))))
(format
"%s %s HTTP/1.1\r\n%s\r\n%s"
(upcase (if (symbolp method) (symbol-name method) method))
resource
(loop for header in headers
if (equal (header-name header) "body")
do (setq body (cdr header))
else
concat (format
"%s: %s\r\n"
(capitalize (header-name header))
(cdr header)))
;; If we have a body then add that as well
(or body "")))))
(defun elnode/get-or-make-con-buffer (httpcon)
(or
(process-buffer httpcon)
(let* ((port (cadr (process-contact httpcon)))
(buf (get-buffer-create (format " *elnode-request-%s*" port))))
(set-process-buffer httpcon buf)
(process-buffer httpcon))))
(defsubst elnode--call (handler con)
(funcall handler con))
(defun elnode--filter (process data)
"Filtering DATA sent from the client PROCESS..
This does the work of finding and calling the user HTTP
connection handler for the request on PROCESS.
A buffer for the HTTP connection is created, uniquified by the
port number of the connection."
(with-current-buffer (elnode/get-or-make-con-buffer process)
(insert data)
(elnode/case (catch 'elnode-parse-http (elnode--http-parse process))
('header (elnode-msg :info "filter: partial header data received"))
('content (elnode-msg :info "filter: partial header data received"))
('done
(save-excursion
(goto-char (elnode/con-get process :elnode-header-end))
(let ((handler (elnode/get-server-prop process :elnode-http-handler)))
(unwind-protect
(condition-case signal-value
(funcall handler process)
('elnode-defer ; see elnode-defer-now
(elnode-msg :info "filter: defer caught on %s" process)
;; Check the timer, this is probably spurious but useful "for now"
(unless elnode-defer-on
(elnode-msg :info "filter: no defer timer for %s" process))
(elnode/case (elnode/get-server-prop process :elnode-defer-mode)
(:managed
(elnode/con-put process :elnode-deferred t)
;; the cdr of the sig value is the func
(elnode--deferred-add process (cdr signal-value)))
(:immediate
(elnode-msg :info "filter: immediate defer on %s" process)
(funcall (cdr signal-value) process))))
('t
(unless (or (elnode/con-get process :elnode-child-process)
(elnode/con-get process :elnode-http-started))
(elnode-msg :info "filter: default handling %S" signal-value)
(process-send-string process (elnode--format-response 500)))))
(if (and (not (or
(elnode/con-get process :elnode-http-started)
(elnode/con-get process :elnode-child-process)))
(not (elnode/con-get process :elnode-deferred)))
(process-send-string process (elnode--format-response 500))
;; Else
(when (elnode/con-get process :elnode-finished)
(unwind-protect
(progn
(delete-process process)
(kill-buffer (process-buffer process)))
(unless (eq 'closed (process-status process))
(elnode-msg :warning "elnode--filter failed at the end"))))))))))))
(defun elnode--ip-addr->string (ip-addr)
"Turn a vector IP-ADDR into a string form.
The vector form is produced by `process-contact' and includes the
port number."
(destructuring-bind (a b c d port)
(mapcar 'identity ip-addr)
(format "%s.%s.%s.%s:%s" a b c d port)))
(defun elnode-get-remote-ipaddr (httpcon)
"Return the remote IP address from the HTTPCON.
Returned as a dotted ip address followed by a colon separated
port number. For example: \"127.0.0.1:8080\"."
(let* ((remote (plist-get
(process-contact httpcon t)
:remote)))
(elnode--ip-addr->string remote)))
(defun elnode-server-info (httpcon)
"Returns a string adress of the server host and port for HTTPCON.
For example: \"127.0.0.1:8000\" - localhost on port 8000."
(elnode--ip-addr->string
(plist-get
(process-contact (elnode/con-get httpcon :server) t)
:local)))
;;; Parsing
(defun elnode--alist-to-query (alist)
"Turn an alist into a formdata/query string."
(noflet ((web--key-value-encode (key value)
"Encode a KEY and VALUE for url encoding."
(cond
((or
(numberp value)
(stringp value))
(format
"%s=%s"
(url-hexify-string (format "%s" key))
(url-hexify-string (format "%s" value))))
(t
(format "%s" (url-hexify-string (format "%s" key))))))
(web--to-query-string (object)
"Convert OBJECT (a hash-table or alist) to an HTTP query string."
;; Stolen from web
(mapconcat
(lambda (pair)
(web--key-value-encode (car pair) (cdr pair)))
(cond
((hash-table-p object)
(let (result)
(maphash
(lambda (key value)
(setq result (append (list (cons key value)) result)))
object)
(reverse result)))
((listp object)
object))
"&")))
(web--to-query-string alist)))
(defun elnode--make-test-call (path method parameters headers)
"Construct the HTTP request for a test call.
This should probably be merged with the stuff in the `web'
module."
(let* ((query
(if (and parameters (equal method "GET"))
(format
"?%s"
(elnode--alist-to-query parameters))
""))
(http-path
(if (equal query "")
path
(format "%s%s" path query)))
(http-body
(if (equal method "GET")
nil
(let ((param-data (elnode--alist-to-query parameters)))
(setq headers
(append
(list
(cons "Content-Type"
"application/x-www-form-urlencoded")
(cons "Content-Length"
(format "%d" (length param-data))))
headers))
param-data))))
(apply
'elnode--http-make-hdr
`(,method
,http-path
,@headers
(body . ,http-body)))))
(defun elnode--response-header-to-cookie-store (response)
"Add Set-Cookie headers from RESPONSE to the cookie store."
(let ((cookie-set (assoc "Set-Cookie" response)))
(when cookie-set
(let* ((cookie-value (car (split-string (cdr cookie-set) ";"))))
(apply
'puthash
(append
(split-string cookie-value "=")
(list elnode--cookie-store))))))
elnode--cookie-store)