ADD: with-locale to fix the time string bug.
[glow:ragnarok.git] / ragnarok / protocol / http / response.scm
1 ;;  Copyright (C) 2011-2012  
2 ;;      "Mu Lei" known as "NalaGinrut" <NalaGinrut@gmail.com>
3 ;;  Ragnarok is free software: you can redistribute it and/or modify
4 ;;  it under the terms of the GNU General Public License as published by
5 ;;  the Free Software Foundation, either version 3 of the License, or
6 ;;  (at your option) any later version.
7
8 ;;  Ragnarok is distributed in the hope that it will be useful,
9 ;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
10 ;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
11 ;;  GNU General Public License for more details.
12
13 ;;  You should have received a copy of the GNU General Public License
14 ;;  along with this program.  If not, see <http://www.gnu.org/licenses/>.
15
16 (define-module (ragnarok protocol http response)
17   #:use-module (ragnarok protocol http header)
18   #:use-module (srfi srfi-9)
19   #:export (build-response
20             write-response
21             write-response-body))
22
23 (define put-bytevector (@ (rnrs io ports) put-bytevector))
24 (define-record-type response-type
25   (make-response-type version code reason headers charset)
26   response-type?
27   (version response:version)
28   (code response:code)
29   (reason response:reason)
30   (headers response:headers)
31   (charset response:charset))
32
33 (define gen-header-str
34   (lambda (headers)
35     (call-with-output-string
36      (lambda (p)
37        (for-each (lambda (h)
38                    (let ([head-str (http-header (car h)
39                                                 (cdr h))])
40                      (if head-str
41                          (format p "~%~a" head-str)
42                          )))
43                  headers)
44        ))))
45
46 ;; Rewrite from (web response), this version is smarter (I think, at least).
47 ;; NOTE: We don't need to verify the headers, because we can make sure of it.
48 (define* (build-response
49           #:key
50           (version 1.1) 
51           (code 200)
52           (headers '())
53           reason
54           (charset "iso-8859-1")
55           )
56   (make-response-type version code reason headers charset)
57   )
58
59 (define write-response
60   (lambda (response port)
61     (let* ([version (object->string (response:version response))]
62            [code (response:code response)]
63            [reason (response:reason response)]
64            [headers (gen-header-str (response:headers response))]
65            [charset (response:charset response)]
66            )
67       (format port "HTTP/~a ~a ~a ~a; charset=~a~%~%"
68               version code reason headers charset)
69       )))
70        
71 (define-syntax write-response-body
72   (syntax-rules ()
73     ((_ bv port)
74      (put-bytevector port bv)
75      )))
76
77