summaryrefslogtreecommitdiff
path: root/intarweb.scm
blob: 013fafa35fa619df31facdd169b311d60c0a2f7f (plain)
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
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
;;;
;;; Intarweb is an improved HTTP library for Chicken
;;;
;; Copyright (c) 2008-2021, Peter Bex
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;; 3. Neither the name of the author nor the names of its
;;    contributors may be used to endorse or promote products derived
;;    from this software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
;; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
;; OF THE POSSIBILITY OF SUCH DAMAGE.

;; TODO: Support RFC5987?  Seems awfully messy though (need to pull in iconv?)
;; We could use http://www.greenbytes.de/tech/tc2231/ in the testsuite.
;; Look at that URI's toplevel directory for more HTTP/URI-related testcases!

(module intarweb
  (http-line-limit http-header-limit http-urlencoded-request-data-limit
   replace-header-contents replace-header-contents! remove-header remove-header!
   update-header-contents update-header-contents! headers single-headers
   headers? headers->list http-name->symbol symbol->http-name
   header-parsers header-unparsers unparse-header unparse-headers read-headers
   safe-methods safe? idempotent-methods idempotent? keep-alive? response-class
   etag=? etag=-weakly? etag-matches? etag-matches-weakly?
   
   make-request request? request-major request-major-set!
   request-minor request-minor-set!
   request-method request-method-set! request-uri request-uri-set!
   request-headers request-headers-set! request-port request-port-set!
   update-request set-request! request-has-message-body?

   request-parsers read-request request-unparsers write-request
   finish-request-body http-0.9-request-parser http-1.x-request-parser
   http-0.9-request-unparser http-1.0-request-unparser http-1.x-request-unparser
   header-parse-error-handler
   read-urlencoded-request-data
   
   make-response response? response-major response-major-set!
   response-minor response-minor-set!
   response-code response-code-set! response-reason response-reason-set!
   response-status response-status-set! response-headers response-headers-set!
   response-port response-port-set! update-response set-response!
   response-has-message-body-for-request?
   
   write-response response-parsers response-unparsers read-response
   finish-response-body http-0.9-response-parser http-0.9-response-unparser
   http-1.0-response-parser http-1.0-response-unparser
   http-1.x-response-parser http-1.x-response-unparser
   http-status-codes http-status->code&reason

   ;; http-header-parsers
   header-contents header-values header-value header-params header-param
   get-value get-params get-param

   split-multi-header parse-token parse-comment
   parse-params parse-value+params unparse-params
   multiple single make-key/value-subparser
   
   rfc1123-time->string rfc1123-string->time rfc850-string->time asctime-string->time
   http-date-string->time
   rfc1123-subparser rfc850-subparser  asctime-subparser http-date-subparser
   product-subparser quality-subparser unknown-header-parser
   filename-subparser symbol-subparser symbol-subparser-ci natnum-subparser
   host/port-subparser base64-subparser range-subparser filename-subparser
   etag-parser software-parser mailbox-subparser
   if-range-parser retry-after-subparser via-parser warning-parser
   key/value-subparser set-cookie-parser cache-control-parser pragma-parser
   te-parser cookie-parser strict-transport-security-parser
   
   must-be-quoted-chars quote-string unparse-token
   default-header-unparser etag-unparser host/port-unparser
   product-unparser software-unparser rfc1123-unparser cookie-unparser
   strict-transport-security-unparser

   ;; Subparsers/subunparsers
   authorization-param-subparsers
   basic-auth-param-subparser digest-auth-param-subparser
   
   authorization-param-subunparsers
   basic-auth-param-subunparser digest-auth-param-subunparser
   )

(import scheme (chicken base) (chicken foreign) (chicken irregex)
        (chicken format) (chicken io) (chicken string)
        (chicken time posix) (chicken pathname) (chicken fixnum)
        (chicken condition) (chicken port) (chicken syntax)
        srfi-1 srfi-13 srfi-14 base64 uri-common defstruct)

;; The below can all be #f if you want no limit (not recommended!)
(define http-line-limit (make-parameter 4096))
(define http-header-limit (make-parameter 64))
(define http-urlencoded-request-data-limit (make-parameter (* 4 1024 1024)))

(define (read-urlencoded-request-data
         request #!optional (max-length (http-urlencoded-request-data-limit)))
  (let* ((p (request-port request))
         (len (header-value 'content-length (request-headers request)))
         ;; For simplicity's sake, we don't allow exactly the max request limit
         (limit (if (and len max-length)
                    (min len max-length)
                    (or max-length len)))
         (data (read-string limit (request-port request))))
    (if (and (not (eof-object? data)) max-length (= max-length (string-length data)))
        (signal-http-condition
         'read-urlencoded-request-data
         "Max allowed URLencoded request size exceeded"
         (list request max-length)
         'urlencoded-request-data-limit-exceeded
         'contents data 'limit limit)
        (form-urldecode data))))

(define (raise-line-limit-exceeded-error line limit port)
  (let ((safe-line-prefix
         (if (< limit 128)
             (sprintf "~A[..and more (was limited to ~A)..]" line limit)
             (sprintf "~A[..~A+ more chars (was limited to ~A)..]"
               (substring line 0 128) (- limit 128) limit))))
    (signal-http-condition
     'safe-read-line
     "Max allowed line length exceeded"
     (list port safe-line-prefix)
     'line-limit-exceeded 'contents line 'limit limit)))

(define (safe-read-line p)
  (let* ((limit (http-line-limit))
         (line (read-line p (http-line-limit))))
    (if (and (not (eof-object? line)) limit (= limit (string-length line)))
        (raise-line-limit-exceeded-error line limit p)
        line)))

;; Make headers a new type, to force the use of the HEADERS procedure
;; and ensure only proper header values are passed to all procedures
;; that deal with headers.
(define-record headers v)

(define-record-printer (headers h out)
  (fprintf out "#(headers: ~S)" (headers-v h)))

(define headers->list headers-v)

(define (remove-header! name headers)
  (let loop ((h (headers-v headers)))
    (cond
     ((null? h) headers)
     ((eq? name (caar h))
      (set-cdr! h (cdr h))
      headers)
     (else (loop (cdr h))))))

(define (remove-header name headers)
  (make-headers
   (let loop ((h (headers-v headers)))
     (cond
      ((null? h) h)
      ((eq? name (caar h)) (loop (cdr h)))
      (else (cons (car h) (loop (cdr h))))))))

;; Check that the header values are valid vectors, and that if there
;; is a raw value, there is only one value at all.
(define (check-header-values loc name contents)
  (let lp ((mode 'unknown) (todo contents))
    (let ((head (car todo)))
      (if (not (and (vector? head) (= 2 (vector-length head))))
          (signal-http-condition
           loc "header values must be vectors of length 2"
           (list name contents) 'header-value)
          (let ((type (if (eq? (get-params head) 'raw) 'raw 'cooked)))
            (unless (or (eq? mode 'unknown) (eq? mode type))
              (signal-http-condition
               loc "When using raw headers, all values must be raw"
               (list name contents) 'header-value)
              (lp type (cdr todo))))))))

;; XXX: Do we need these replace procedures in the exports list?  It
;; looks like we can use update everywhere.
(define (replace-header-contents! name contents headers)
  (check-header-values 'replace-header-contents! name contents)
  (let loop ((h (headers-v headers)))
    (cond
     ((null? h)
      (headers-v-set!
       headers (cons (cons name contents) (headers-v headers)))
      headers)
     ((eq? name (caar h))
      (set-cdr! (car h) contents)
      headers)
     (else (loop (cdr h))))))

(define (replace-header-contents name contents headers)
  (check-header-values 'replace-header-contents! name contents)
  (make-headers
   (let loop ((h (headers-v headers)))
     (cond
      ((null? h) (cons (cons name contents) h))
      ((eq? name (caar h))
       (cons (cons (caar h) contents) (cdr h)))
      (else (cons (car h) (loop (cdr h))))))))

(define (make-updater replacer)
  (lambda (name contents headers)
    (let ((old (header-contents name headers '())))
      (replacer name
                (if (member name (single-headers))
                    (list (last contents))
                    (append old contents))
                headers))))

(define update-header-contents  (make-updater replace-header-contents))
(define update-header-contents! (make-updater replace-header-contents!))

(define http-name->symbol (compose string->symbol string-downcase!))
(define symbol->http-name (compose string-titlecase symbol->string))

;; Make a header set from a literal expression by folding in the headers
;; with any previous ones
(define (headers headers-to-be #!optional (old-headers (make-headers '())))
  (fold (lambda (h new-headers)
          (update-header-contents
           (car h)
           (map (lambda (v)
                  (if (vector? v) v (vector v '()))) ; normalize to vector
                (cdr h))
           new-headers))
        old-headers
        headers-to-be))

(define (normalized-uri str)
  (and-let* ((uri (uri-reference str)))
    (uri-normalize-path-segments uri)))

(include "header-parsers") ; Also includes header unparsers

;; Any unknown headers are considered to be multi-headers, always
(define single-headers
  (make-parameter '(accept-ranges age authorization content-disposition
                    content-length content-location content-md5 content-type
                    date etag expect expires host if-modified-since
                    if-unmodified-since last-modified location max-forwards
                    proxy-authorization range referer retry-after server
                    transfer-encoding user-agent www-authenticate)))

(define string->http-method string->symbol)
(define http-method->string symbol->string)

;; Make an output port automatically "chunked"
(define (chunked-output-port port)
  (let ((chunked-port
         (make-output-port (lambda (s)        ; write
                             (let ((len (string-length s)))
                               (unless (zero? len)
                                 (fprintf port "~X\r\n~A\r\n" len s))))
                           (lambda ()         ; close
                             (close-output-port port))
                           (lambda ()         ; flush
                             (flush-output port)))))
    ;; first "reserved" slot
    ;; Slot 7 should probably stay 'custom
    (##sys#setslot chunked-port 10 'chunked-output-port)
    ;; second "reserved" slot
    (##sys#setslot chunked-port 11 port)
    chunked-port))

;; Make an input port automatically "chunked"
(define (chunked-input-port port)
  (let* ((chunk-length 0)
         (position 0)
         (check-position (lambda ()
                           (when (and position (>= position chunk-length))
                             (unless (eq? chunk-length 0)
                               (safe-read-line port)) ; Read \r\n data trailer
                             (let ((line (safe-read-line port)))
                               (if (eof-object? line)
                                   (set! position #f)
                                   (begin
                                     (set! chunk-length (string->number line 16))
                                     (cond
                                      ((not chunk-length) (set! position #f))
                                      ((zero? chunk-length) ; Read final data trailer
                                       (safe-read-line port)
                                       (set! position #f))
                                      (else (set! position 0))))))))))
    (make-input-port (lambda ()         ; read-char
                       (check-position)
                       (if position
                           (let ((char (read-char port)))
                             (unless (eof-object? char)
                               (set! position (add1 position)))
                             char)
                           #!eof))
                     (lambda ()         ; ready?
                       (check-position)
                       (or (not position) (char-ready? port)))
                     (lambda ()         ; close
                       (close-input-port port))
                     (lambda ()         ; peek-char
                       (check-position)
                       (if position
                           (peek-char port)
                           #!eof))
                     (lambda (p bytes buf off) ; read-string!
                       (let lp ((todo bytes)
                                (total-bytes-read 0)
                                (off off))
                         (check-position)
                         (if (or (not position) (= todo 0))
                             total-bytes-read
                             (let* ((n (min todo (- chunk-length position)))
                                    (bytes-read (read-string! n buf port off)))
                               (set! position (+ position bytes-read))
                               (lp (- todo bytes-read)
                                   (+ total-bytes-read bytes-read)
                                   (+ off bytes-read)))))))))
;; TODO: Note that in the above, read-line is not currently
;; implemented.  It is *extremely* tricky to correctly maintain the
;; port position when all \r *AND/OR* \n characters get chopped off
;; the line-string.  It can be done by maintaining our own extra
;; buffer, but that complicates all the procedures here enormously,
;; including read-line itself.

;; RFC2616, Section 4.3: "The presence of a message-body in a request
;; is signaled by the inclusion of a Content-Length or Transfer-Encoding
;; header field in the request's message-headers."
;; We don't check the method since "a server SHOULD read and forward the
;; a message-body on any request", even it shouldn't be sent for that method.
;;
;; Because HTTP/1.0 has no official definition of when a message body
;; is present, we'll assume it's always present, unless there is no
;; content-length and we have a keep-alive connection.
(define request-has-message-body?
  (make-parameter
   (lambda (req)
     (let ((headers (request-headers req)))
       (if (and (= 1 (request-major req)) (= 0 (request-minor req)))
           (not (eq? 'keep-alive (header-contents 'connection headers)))
           (or (header-contents 'content-length headers)
               (header-contents 'transfer-encoding headers)))))))

;; RFC2616, Section 4.3: "For response messages, whether or not a
;; message-body is included with a message is dependent on both the
;; request method and the response status code (section 6.1.1)."
(define response-has-message-body-for-request?
  (make-parameter
   (lambda (resp req)
     (not (or (= (response-class resp) 100)
              (memv (response-code resp) '(204 304))
              (eq? 'HEAD (request-method req)))))))

;; OPTIONS and TRACE are not explicitly mentioned in section 9.1.1,
;; but section 9.1.2 says they SHOULD NOT have side-effects by
;; definition, which means they are safe, as well.
(define safe-methods
  (make-parameter '(GET HEAD OPTIONS TRACE)))

;; RFC2616, Section 9.1.1
(define (safe? obj)
  (let ((method (if (request? obj) (request-method obj) obj)))
    (not (not (member method (safe-methods))))))

(define idempotent-methods
  (make-parameter '(GET HEAD PUT DELETE OPTIONS TRACE)))

;; RFC2616, Section 9.1.2
(define (idempotent? obj)
  (let ((method (if (request? obj) (request-method obj) obj)))
    (not (not (member method (idempotent-methods))))))

(define (keep-alive? obj)
  (let ((major (if (request? obj) (request-major obj) (response-major obj)))
        (minor (if (request? obj) (request-minor obj) (response-minor obj)))
        (con   (header-value 'connection (if (request? obj)
                                             (request-headers obj)
                                             (response-headers obj)))))
   (if (and (= major 1) (> minor 0))
       (not (eq? con 'close))
       ;; RFC 2068, section 19.7.1 (see also RFC 2616, section 19.6.2)
       (eq? con 'keep-alive))))

(define (etag=? a b)
  (and (not (eq? 'weak (car a)))
       (eq? (car a) (car b))
       (string=? (cdr a) (cdr b))))

(define (etag=-weakly? a b)
  (and (eq? (car a) (car b))
       (string=? (cdr a) (cdr b))))

(define (etag-matches? etag matchlist)
  (any (lambda (m) (or (eq? m '*) (etag=? etag m))) matchlist))

(define (etag-matches-weakly? etag matchlist)
  (any (lambda (m) (or (eq? m '*) (etag=-weakly? etag m))) matchlist))

;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Request parsing ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;

;; This includes parsers for all RFC-defined headers
(define header-parsers
  (make-parameter
   `((accept . ,(multiple symbol-subparser-ci
                          `((q . ,quality-subparser))))
     (accept-charset . ,(multiple symbol-subparser-ci
                                  `((q . ,quality-subparser))))
     (accept-encoding . ,(multiple symbol-subparser-ci
                                   `((q . ,quality-subparser))))
     (accept-language . ,(multiple symbol-subparser-ci
                                   `((q . ,quality-subparser))))
     (accept-ranges . ,(single symbol-subparser-ci))
     (age . ,(single natnum-subparser))
     (allow . ,(multiple symbol-subparser))
     (authorization . ,authorization-parser)
     (cache-control . ,cache-control-parser)
     (connection . ,(multiple symbol-subparser-ci))
     (content-encoding . ,(multiple symbol-subparser-ci))
     (content-language . ,(multiple symbol-subparser-ci))
     (content-length . ,(single natnum-subparser))
     (content-location . ,(single normalized-uri))
     (content-md5 . ,(single base64-subparser))
     (content-range . ,(single range-subparser))
     (content-type . ,(single symbol-subparser-ci
                              `((charset . ,symbol-subparser-ci))))
     (date . ,(single http-date-subparser))
     (etag . ,etag-parser)
     (expect . ,(single (make-key/value-subparser '())))
     (expires . ,(single http-date-subparser))
     (from . ,(multiple mailbox-subparser))
     (host . ,(single host/port-subparser))
     (if-match . ,if-match-parser)
     (if-modified-since . ,(single http-date-subparser))
     (if-none-match . ,if-match-parser)
     (if-range . ,if-range-parser)
     (if-unmodified-since . ,(single http-date-subparser))
     (last-modified . ,(single http-date-subparser))
     (location . ,(single normalized-uri))
     (max-forwards . ,(single natnum-subparser))
     (pragma . ,pragma-parser)
     (proxy-authenticate . ,authenticate-parser)
     (proxy-authorization . ,authorization-parser)
     (range . ,(multiple range-subparser))
     (referer . ,(single normalized-uri))
     (retry-after . ,(single retry-after-subparser))
     (server . ,software-parser)
     (te . ,te-parser)
     (trailer . ,(multiple symbol-subparser-ci))
     (transfer-encoding . ,(single symbol-subparser-ci))
     (upgrade . ,(multiple product-subparser))
     (user-agent . ,software-parser)
     (vary . ,(multiple symbol-subparser-ci))
     (via . ,via-parser)
     (warning . ,warning-parser)
     (www-authenticate . ,authenticate-parser)
     ;; RFC 2183
     (content-disposition . ,(single symbol-subparser-ci
                                     `((filename . ,filename-subparser)
                                       (creation-date . ,rfc1123-subparser)
                                       (modification-date . ,rfc1123-subparser)
                                       (read-date . ,rfc1123-subparser)
                                       (size . ,natnum-subparser))))
     ;; RFC 2109
     (set-cookie . ,set-cookie-parser)
     (cookie . ,cookie-parser)
     ;;
     ;; TODO: RFC 2965?
     ;;
     ;; RFC 6797
     (strict-transport-security . ,strict-transport-security-parser)
     ;; Nonstandard but common headers
     (x-forwarded-for . ,(multiple identity))
     )))

(define header-parse-error-handler ;; ignore errors
  (make-parameter (lambda (header-name contents headers exn) headers)))

;; The parser is supposed to return a list of header values for its header
(define (parse-header name contents)
  (let* ((default unknown-header-parser)
         (parser (alist-ref name (header-parsers) eq? default)))
    (parser contents)))

(define (parse-header-line line headers)
  (or
   (and-let* ((colon-idx   (string-index line #\:))
              (header-name (http-name->symbol (string-take line colon-idx)))
              (contents    (string-trim-both (string-drop line (add1 colon-idx)))))
     (handle-exceptions
      exn
      ((header-parse-error-handler) header-name contents headers exn)
      (update-header-contents!
       header-name (parse-header header-name contents) headers)))
   (signal-http-condition
    'parse-header-line "Bad header line" (list line)
    'header-error 'contents line)))

;; XXXX: Bottleneck?
(define (read-headers port)
  (if (eof-object? (peek-char port))    ; Yeah, so sue me
      (make-headers '())
      (let ((header-limit (http-header-limit))
            (line-limit (http-line-limit)))
        (let lp ((c (read-char port))
                 (ln '())
                 (headers (make-headers '()))
                 (hc 0)
                 (len 0))
          (cond ((eqv? len line-limit)
                 (raise-line-limit-exceeded-error
                  (reverse-list->string ln) line-limit port))
                ((eof-object? c)
                 (if (null? ln)
                     headers
                     (parse-header-line (reverse-list->string ln) headers)))
                ;; Only accept CRLF (we're not this strict everywhere...)
                ((and (eqv? c #\return) (eqv? (peek-char port) #\newline))
                 (read-char port)       ; Consume and discard NL
                 (if (null? ln)         ; Nothing came before: end of headers
                     headers
                     (let ((pc (peek-char port)))
                       (if (and (not (eof-object? pc))
                                (or (eqv? pc #\space) (eqv? pc #\tab)))
                           ;; If the next line starts with whitespace,
                           ;; it's a continuation line of the same
                           ;; header.  See section 2.2 of RFC 2616.
                           (let skip ((pc (read-char port)) (len len) (ln ln))
                             (if (and (not (eqv? len line-limit))
                                      (or (eqv? pc #\space) (eqv? pc #\tab)))
                                 (skip (read-char port) (add1 len) (cons pc ln))
                                 (lp pc ln headers hc len)))
                           (let* ((ln (reverse-list->string ln))
                                  (headers (parse-header-line ln headers))
                                  (hc (add1 hc)))
                             (when (eqv? hc header-limit)
                               (signal-http-condition
                                'read-headers
                                "Max allowed header count exceeded"
                                (list port)
                                'header-limit-exceeded
                                'contents ln
                                'headers headers
                                'limit header-limit))
                             (lp (read-char port) '() headers hc 0))))))
                ((eqv? c #\")
                 (let lp2 ((c2 (read-char port))
                           (ln (cons c ln))
                           (len len))
                   (cond ((or (eqv? 0 len) (eof-object? c2))
                          (lp c2 ln headers hc len))
                         ((eqv? c2 #\")
                          (lp (read-char port) (cons c2 ln)
                              headers hc (add1 len)))
                         ((eqv? c2 #\\)
                          (let ((c3 (read-char port))
                                (len len))
                            (if (or (eof-object? c3) (eqv? 0 len))
                                (lp c3 (cons c2 ln) headers hc len)
                                (lp2 (read-char port)
                                     (cons c3 (cons c2 ln))
                                     (add1 len)))))
                         (else
                          (lp2 (read-char port) (cons c2 ln) (add1 len))))))
                (else
                 (lp (read-char port) (cons c ln) headers hc (add1 len))))))))

(define (signal-http-condition loc msg args type . more-info)
  (signal (make-composite-condition
           (make-property-condition 'http)
           (apply make-property-condition type more-info)
           (make-property-condition
            'exn 'location loc 'message msg 'arguments args))))

(defstruct request
  (method 'GET) uri (major 1) (minor 1) (headers (make-headers '())) port)

;; Perhaps we should have header parsers indexed by version or
;; something like that, so you can define the maximum version. Useful
;; for when expecting a response. Then we group request/response parsers
;; together, as with request/response unparsers.
(define http-0.9-request-parser
  (let ((req (irregex '(seq (w/nocase "GET") (+ space) (=> uri (* any))))))
    (lambda (line in)
      (and-let* ((m (irregex-match req line))
                 (uri (normalized-uri (irregex-match-substring m 'uri))))
        (make-request method: 'GET uri: uri
                      major: 0 minor: 9 port: in)))))

;; Might want to reuse this elsewhere
(define token-sre '(+ (~ "()<>@,;:\\\"/[]?={}\t ")))

;; XXX This actually parses anything >= HTTP/1.0
(define http-1.x-request-parser
  (let ((req (irregex `(seq (=> method ,token-sre) (+ space)
                            (=> uri (+ (~ blank))) ; uri-common handles details
                            (+ space) (w/nocase "HTTP/")
                            (=> major (+ digit)) "." (=> minor (+ digit))))))
    (lambda (line in)
      (and-let* ((m (irregex-match req line))
                 (uri-string (irregex-match-substring m 'uri))
                 (major (string->number (irregex-match-substring m 'major)))
                 (minor (string->number (irregex-match-substring m 'minor)))
                 (method (string->http-method (irregex-match-substring m 'method)))
                 (headers (read-headers in)))
        (let* ((wildcard (string=? uri-string "*"))
               (uri (and (not wildcard) (normalized-uri uri-string)))
               ;; HTTP/1.0 has no chunking
               (port (if (and (or (> major 1) (>= minor 1))
                              (memq 'chunked
                                    (header-values
                                     'transfer-encoding headers)))
                         (chunked-input-port in)
                         in)))
          ;; HTTP/1.1 allows several "things" as "URI" (RFC2616, 5.1.2):
          ;; Request-URI = "*" | absoluteURI | abs_path | authority
          ;;
          ;; HTTP/1.0, URIs are more limited (RFC1945, 5.1.2):
          ;; Request-URI = absoluteURI | abs_path
          ;;
          ;; Currently, a plain authority is not accepted.  This would
          ;; require deep changes in the representation of request
          ;; objects.  It is only used in CONNECT requests, so
          ;; currently not much of a problem.  If we want to support
          ;; this, we'd need a separate object type and expose a
          ;; parser from uri-generic/uri-common for just authority.
          (and (or (and wildcard (or (> major 1) (>= minor 1)))
                   (and uri (or (absolute-uri? uri)
                                (and (uri-path-absolute? uri)
                                     (not (uri-host uri))))))
               (make-request method: method uri: uri
                             major: major minor: minor
                             headers: headers
                             port: port)))))))

(define request-parsers   ; order matters here
  (make-parameter (list http-1.x-request-parser)))

(define (read-request inport)
  (let ((line (safe-read-line inport)))
    (and (not (eof-object? line))
         ;; Try each parser in turn to process the request-line.
         ;; A parser returns either #f or a request object
         (let loop ((parsers (request-parsers)))
           (if (null? parsers)
               (signal-http-condition
                'read-request "Unknown protocol line" (list line)
                'unknown-protocol-line 'line line)
               (or ((car parsers) line inport) (loop (cdr parsers))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Request unparsing ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define header-unparsers
  (make-parameter
   `((content-disposition . ,content-disposition-unparser)
     (date . ,rfc1123-unparser)
     (etag . ,etag-unparser)
     (expires . ,rfc1123-unparser)
     (host . ,host/port-unparser)
     (if-match . ,if-match-unparser)
     (if-modified-since . ,rfc1123-unparser)
     (if-none-match . ,if-match-unparser)
     (if-unmodified-since . ,rfc1123-unparser)
     (last-modified . ,rfc1123-unparser)
     (user-agent . ,software-unparser)
     (server . ,software-unparser)
     (upgrade . ,product-unparser)
     (cookie . ,cookie-unparser)
     (set-cookie . ,set-cookie-unparser)
     (authorization . ,authorization-unparser)
     (www-authenticate . ,authenticate-unparser)
     (proxy-authorization . ,authorization-unparser)
     (proxy-authenticate . ,authenticate-unparser)
     (via . ,via-unparser)
     ;; RFC 6797
     (strict-transport-security . ,strict-transport-security-unparser))))

(define (unparse-header header-name header-value)
  (cond ((and (not (null? header-value))
              (eq? 'raw (get-params (car header-value))))
         (map get-no-newline-value header-value))
        ((assq header-name (header-unparsers))
         => (lambda (unparser) ((cdr unparser) header-value)))
        (else (default-header-unparser header-value))))

(define (unparse-headers headers out)
  (let ((unparsers (header-unparsers))) ; Don't access parameter for each header
    (for-each
     (lambda (h)
       (let* ((name (car h))
              (name-s (symbol->http-name name))
              (contents (cdr h))
              (unparse (cond ((assq name unparsers) => cdr) ; inlined for perf
                             (else default-header-unparser))))
         (handle-exceptions exn
             (if ((condition-predicate 'http) exn)
                 (signal exn) ;; Do not tamper with our own custom errors
                 (let* ((none "(no error message provided in original exn)")
                        (msg ((condition-property-accessor
                               'exn 'message none) exn))
                        (loc ((condition-property-accessor
                               'exn 'location #f) exn))
                        (args ((condition-property-accessor
                                'exn 'arguments '()) exn)))
                   (signal-http-condition
                    'unparse-headers
                    (sprintf "could not unparse ~S header ~S: ~A~A"
                      name-s contents (if loc (sprintf "(~A) " loc) "") msg)
                    args
                    'unparse-error
                    'header-name name
                    'header-value contents
                    'unparser unparse
                    'original-exn exn)))
           (let ((lines (if (and (not (null? contents))
                                 (eq? 'raw (get-params (car contents))))
                            (map get-no-newline-value contents)
                            (unparse contents))))
             (for-each (lambda (value)
                         ;; Verify there's no \r\n or \r or \n in value?
                         (display (string-append name-s ": " value "\r\n") out))
                       lines)))))
     (headers-v headers))))

;; Use string-append and display rather than fprintf so the line gets
;; written in one burst.  This supposedly avoids a strange race
;; condition, see #800.  We use string-append instead of sprintf for
;; performance reasons.  This is not exported, and our callers compare
;; request-major and request-minor so we can assume they're numbers.
(define (write-request-line request)
  (let ((uri (request-uri request)))
    (display (string-append
              (http-method->string (request-method request))
              " " (if uri (uri->string uri) "*") " HTTP/"
              (number->string (request-major request)) "."
              (number->string (request-minor request)) "\r\n")
             (request-port request))))

(define (http-0.9-request-unparser request)
  (display (string-append "GET " (uri->string (request-uri request)) "\r\n")
           (request-port request))
  request)

(define (http-1.0-request-unparser request)
  (and-let* (((= (request-major request) 1))
             ((= (request-minor request) 0))
             (o (request-port request)))
    (write-request-line request)
    (unparse-headers (request-headers request) o)
    (display "\r\n" o)
    request))

;; XXX This actually unparses anything >= HTTP/1.1
(define (http-1.x-request-unparser request)
  (and-let* (((or (> (request-major request) 1)
                  (and (= (request-major request) 1)
                       (> (request-minor request) 0))))
             (o (request-port request)))
    (write-request-line request)
    (unparse-headers (request-headers request) o)
    (display "\r\n" o)
    (if (memq 'chunked (header-values 'transfer-encoding
                                      (request-headers request)))
        (update-request request
                        port: (chunked-output-port (request-port request)))
        request)))

(define request-unparsers  ; order matters here
  (make-parameter (list http-1.x-request-unparser http-1.0-request-unparser)))

(define (write-request request)
  ;; Try each unparser in turn to write the request-line.
  ;; An unparser returns either #f or a new request object.
  (let loop ((unparsers (request-unparsers)))
    (if (null? unparsers)
        (let ((major (request-major request))
              (minor (request-minor request)))
          (signal-http-condition
           'write-request
           "Unknown protocol" (list (conc major "." minor))
           'unknown-protocol 'major major 'minor minor))
        (or ((car unparsers) request) (loop (cdr unparsers))))))

;; Required for chunked requests.  This is a bit of a hack!
(define (finish-request-body request)
  (when (and (memq 'chunked (header-values 'transfer-encoding
                                           (request-headers request)))
             (eq? (##sys#slot (request-port request) 10) 'chunked-output-port))
    (display "0\r\n\r\n" (##sys#slot (request-port request) 11)))
  request)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Response unparsing ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defstruct response
  (code 200) (reason "OK") (major 1) (minor 1) (headers (make-headers '())) port)

(define make-response
  (let ((old-make-response make-response))
    (lambda (#!rest args #!key status code reason)
      (let ((resp (apply old-make-response args)))
        (when (and status (not code) (not reason))
          (response-status-set! resp status))
        resp))))

(define update-response
  (let ((old-update-response update-response))
    (lambda (resp #!rest args #!key status code reason)
      (let ((resp (apply old-update-response resp args)))
        (when (and status (not code) (not reason))
          (response-status-set! resp status))
        resp))))

(define (response-status-set! resp status)
  (receive (code reason) (http-status->code&reason status)
    (response-code-set! resp code)
    (response-reason-set! resp reason)
    resp))

(define (response-class obj)
  (let ((code (if (response? obj) (response-code obj) obj)))
    (- code (modulo code 100))))

(define (response-status obj)
  (let* ((c (if (response? obj) (response-code obj) obj))
         (s (find (lambda (x) (= (cadr x) c)) (http-status-codes))))
    (if s
        (car s)
        (signal-http-condition
         'response-status "Unknown status code" (list c)
         'unknown-code 'code c))))

(define (http-status->code&reason status)
  (let ((s (alist-ref status (http-status-codes))))
    (unless s
      (signal-http-condition
       'http-status->code&reason
       ;; haha, status symbol ;)
       "Unknown response status symbol"
       (list status) 'unknown-status 'status status))
    (values (car s) (cdr s))))

;; List of HTTP status codes based on:
;; http://www.iana.org/assignments/http-status-codes/http-status-codes.xml
(define http-status-codes
  (make-parameter 
   `((continue . (100 . "Continue"))
     (switching-protocols . (101 . "Switching Protocols"))
     (processing . (102 . "Processing"))
     (ok . (200 . "OK"))
     (created . (201 . "Created"))
     (accepted . (202 . "Accepted"))
     (non-authoritative-information . (203 . "Non-Authoritative Information"))
     (no-content . (204 . "No Content"))
     (reset-content . (205 . "Reset Content"))
     (partial-content . (206 . "Partial Content"))
     (multi-status . (207 . "Multi-Status"))
     (already-reported . (208 . "Already Reported"))
     (im-used . (226 . "IM Used"))
     (multiple-choices . (300 . "Multiple Choices"))
     (moved-permanently . (301 . "Moved Permanently"))
     (found . (302 . "Found"))
     (see-other . (303 . "See Other"))
     (not-modified . (304 . "Not Modified"))
     (use-proxy . (305 . "Use Proxy"))
     (temporary-redirect . (307 . "Temporary Redirect"))
     (bad-request . (400 . "Bad Request"))
     (unauthorized . (401 . "Unauthorized"))
     (payment-required . (402 . "Payment Required"))
     (forbidden . (403 . "Forbidden"))
     (not-found . (404 . "Not Found"))
     (method-not-allowed . (405 . "Method Not Allowed"))
     (not-acceptable . (406 . "Not Acceptable"))
     (proxy-authentication-required . (407 . "Proxy Authentication Required"))
     (request-time-out . (408 . "Request Time-out"))
     (conflict . (409 . "Conflict"))
     (gone . (410 . "Gone"))
     (length-required . (411 . "Length Required"))
     (precondition-failed . (412 . "Precondition Failed"))
     (request-entity-too-large . (413 . "Request Entity Too Large"))
     (request-uri-too-large . (414 . "Request-URI Too Large"))
     (unsupported-media-type . (415 . "Unsupported Media Type"))
     (requested-range-not-satisfiable . (416 . "Requested Range Not Satisfiable"))
     (expectation-failed . (417 . "Expectation Failed"))
     (unprocessable-entity . (422 . "Unprocessable Entity"))
     (locked . (423 . "Locked"))
     (failed-dependency . (424 . "Failed Dependency"))
     (upgrade-required . (426 . "Upgrade Required"))
     (precondition-required . (428 . "Precondition Required"))
     (too-many-requests . (429 . "Too Many Requests"))
     (request-header-fields-too-large . (431 . "Request Header Fields Too Large"))
     (internal-server-error . (500 . "Internal Server Error"))
     (not-implemented . (501 . "Not Implemented"))
     (bad-gateway . (502 . "Bad Gateway"))
     (service-unavailable . (503 . "Service Unavailable"))
     (gateway-time-out . (504 . "Gateway Time-out"))
     (http-version-not-supported . (505 . "HTTP Version Not Supported"))
     (insufficient-storage . (507 . "Insufficient Storage"))
     (loop-detected . (508 . "Loop Detected"))
     (not-extended . (510 . "Not Extended"))
     (network-authentication-required . (511 . "Network Authentication Required")))))

(define (http-0.9-response-unparser response)
  response) ;; The response-body will just follow

;; See notes at write-request-line
(define (write-response-line response)
  (display (string-append
            "HTTP/"
            (number->string (response-major response)) "."
            (number->string (response-minor response)) " "
            (->string (response-code response)) " "
            (->string (response-reason response)) "\r\n")
           (response-port response)))

(define (http-1.0-response-unparser response)
  (and-let* (((= (response-major response) 1))
             ((= (response-minor response) 0))
             (o (response-port response)))
    (write-response-line response)
    (unparse-headers (response-headers response) o)
    (display "\r\n" o)
    response))

;; XXX This actually unparses anything >= HTTP/1.1
(define (http-1.x-response-unparser response)
  (and-let* (((or (> (response-major response) 1)
                  (and (= (response-major response) 1)
                       (> (response-minor response) 0))))
             (o (response-port response)))
    (write-response-line response)
    (unparse-headers (response-headers response) o)
    (display "\r\n" o)
    (if (memq 'chunked (header-values 'transfer-encoding
                                      (response-headers response)))
        (update-response response
                         port: (chunked-output-port (response-port response)))
        response)))

(define response-unparsers
  (make-parameter (list http-1.x-response-unparser http-1.0-response-unparser)))

(define (write-response response)
  ;; Try each unparser in turn to write the response-line.
  ;; An unparser returns either #f or a new response object.
  (let loop ((unparsers (response-unparsers)))
    (if (null? unparsers)
        (let ((major (response-major response))
              (minor (response-minor response)))
          (signal-http-condition
           'write-response
           "Unknown protocol" (list (conc major "." minor))
           'unknown-protocol 'major major 'minor minor))
        (or ((car unparsers) response) (loop (cdr unparsers))))))

;; Required for chunked requests.  This is a bit of a hack!
(define (finish-response-body response)
  (when (and (memq 'chunked (header-values 'transfer-encoding
                                           (response-headers response)))
             (eq? (##sys#slot (response-port response) 10) 'chunked-output-port))
    (display "0\r\n\r\n" (##sys#slot (response-port response) 11)))
  response)

;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Response parsing ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;

(define http-1.x-response-parser
  (let ((resp (irregex '(seq (w/nocase "HTTP/")
                             (=> major (+ digit)) "." (=> minor (+ digit))
                             ;; Could use '(= 3 digit) for status-code, but
                             ;; that's currently not compilable
                             (+ space) (=> status-code digit digit digit)
                             (+ space) (=> reason-phrase (* nonl))))))
    (lambda (line in)
      (and-let* ((m (irregex-match resp line))
                 (code (string->number (irregex-match-substring m 'status-code)))
                 (major (string->number (irregex-match-substring m 'major)))
                 (minor (string->number (irregex-match-substring m 'minor)))
                 ((or (> major 1) (and (= major 1) (> minor 0))))
                 (reason (irregex-match-substring m 'reason-phrase))
                 (h (read-headers in))
                 (port (if (memq 'chunked (header-values 'transfer-encoding h))
                           (chunked-input-port in)
                           in)))
        (make-response code: code reason: reason
                       major: major minor: minor
                       headers: h
                       port: port)))))

(define http-1.0-response-parser
  (let ((resp (irregex '(seq (w/nocase "HTTP/1.0")
                             ;; Could use '(= 3 digit) for status-code, but
                             ;; that's currently not compilable
                             (+ space) (=> status-code digit digit digit)
                             (+ space) (=> reason-phrase (* nonl))))))
    (lambda (line in)
      (and-let* ((m (irregex-match resp line))
                 (code (string->number (irregex-match-substring m 'status-code)))
                 (reason (irregex-match-substring m 'reason-phrase))
                 (h (read-headers in)))
        ;; HTTP/1.0 has no chunking
        (make-response code: code reason: reason
                       major: 1 minor: 0
                       headers: h
                       port: in)))))

;; You can't "detect" a 0.9 response, because there is no response line.
;; It will simply output the body directly, so we will just assume that
;; if we can't recognise the output string, we just got a 0.9 response.
(define (http-0.9-response-parser line in)
  (make-response code: 200 reason: "OK"
                 major: 0 minor: 9
                 ;; XXX This is wrong, it re-inserts \r\n, while it may have
                 ;; been a \n only. To work around this, we'd have to write
                 ;; a custom (safe-)read-line procedure.
                 ;; However, it does not matter much because HTTP 0.9 is only
                 ;; defined to ever return text/html, no binary or any other
                 ;; content type.
                 port: (call-with-input-string (string-append line "\r\n")
                         (lambda (str)
                           (make-concatenated-port str in)))))

(define response-parsers ;; order matters here
  (make-parameter (list http-1.x-response-parser http-1.0-response-parser)))

(define (read-response inport)
  (let ((line (safe-read-line inport)))
    (and (not (eof-object? line))
         (let loop ((parsers (response-parsers)))
           (if (null? parsers)
               (signal-http-condition
                'read-response "Unknown protocol line" (list line)
                'unknown-protocol-line 'line line)
               (or ((car parsers) line inport) (loop (cdr parsers))))))))

)