ADD: with-locale to fix the time string bug.
[glow:ragnarok.git] / ragnarok / protocol / http / http.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 http)
17   #:use-module (ragnarok protocol http status)
18   #:use-module (ragnarok protocol http log)
19   #:use-module (ragnarok protocol http response)
20   #:use-module (ragnarok protocol http error)
21   #:use-module (ragnarok log)
22   #:use-module (ragnarok utils)
23   #:use-module (ragnarok msg)
24   #:use-module (ragnarok info)
25   #:use-module (ragnarok error)
26   #:use-module (web uri)
27   #:use-module (web request)
28   #:export (http-handler)
29   )
30
31 (define http-method-handler-get 
32   (@ (ragnarok protocol http method) http-method-handler-get)) 
33 (define init-mime (@ (ragnarok protocol http mime) init-mime))
34 (define *regular-headers* (@ (ragnarok protocol http header) *regular-headers*))
35 (define fold (@ (srfi srfi-1) fold))
36 ;; We use guile native http header parser here.
37 ;; Maybe I'll write a new one later, or I should post a patch to guile
38 ;; to support more MIME.
39
40 ;; FIXME: I need to wrap handler template into a macro.
41 ;;        I believe users don't want to write some meta info by themselves.
42 (define http-handler 
43   (lambda (logger client-connection subserver-info)
44     (let* ([conn-socket (car client-connection)]
45            [conn-detail (cdr client-connection)]
46            [request (get-request logger conn-socket)]
47            [remote-host (car (request-host request))]
48            [remote-addr (inet-ntoa 
49                          (sockaddr:addr conn-detail))]
50            [remote-ident #f] ;; doesn't support
51            [remote-user (request-user-agent request)]
52            [request-method (symbol->string
53                             (request-method request))]
54            [query-string 
55             (uri-query (request-uri request))]
56            [auth-type (request-authorization request)]
57            [content-length (request-content-length request)]
58            [content-type (request-content-type request)]
59            [target (path-fix (uri-path (request-uri request)))]
60            [remote-info 
61             (make-remote-info remote-host remote-addr remote-ident
62                               remote-user request-method query-string
63                               auth-type content-length content-type
64                               target)]
65            [server-info 
66             (make-server-info conn-detail conn-socket
67                               subserver-info remote-info)])
68       (http-request-log logger request)
69       (http-response logger server-info)
70       )))
71
72 (define http-response
73   (lambda (logger server-info)
74     (let* ([subserver-info (server-info:subserver-info server-info)]
75            [charset (subserver-info:server-charset subserver-info)]
76            [connet-info (server-info:connect-info server-info)]
77            [conn-socket (server-info:connect-socket server-info)]
78            [subserver-info (server-info:subserver-info server-info)]
79            [remote-info (server-info:remote-info server-info)]
80            [method (remote-info:request-method remote-info)]
81            [r-handler (http-method-handler-get method)])
82
83       (call-with-values
84           (lambda ()
85             (r-handler logger server-info))
86         (lambda (bv bv-len status type etag mtime)
87           (let* ([reason (or (http-get-reason-from-status status)
88                              "Invalid Status")]
89                  [mt (with-locale LC_TIME "C"
90                                   (->global-time mtime))] ;;return to client as GMT.
91                  [now-time (with-locale LC_TIME "C"
92                                         (get-global-current-time))]
93                  [response (build-response
94                             #:version 1.1
95                             #:code status
96                             #:reason reason
97                             #:headers `(,@*regular-headers*
98                                         (date . ,now-time)
99                                         (last-modified . ,mt)
100                                         (eTag . ,etag)
101                                         ;; NOTE: keep these two lines last!
102                                         (content-length . ,bv-len)
103                                         (content-type . ,type)
104                                         )
105                             #:charset charset
106                             )])
107             (write-response response conn-socket)
108             (and bv (write-response-body bv conn-socket))
109             ;;(http-response-log logger status)
110             ))))))
111
112 (define get-request
113   (lambda (logger conn-socket)
114     (let* ([request (read-request conn-socket)]
115            
116            ;; FIXME: we should have a more pretty info print...
117            [request-info (fold 
118                           (lambda (x y) 
119                             (string-append y (format #f "~a : ~a~%" 
120                                                      (object->string (car x))
121                                                      (object->string (cdr x)))))
122                           ""
123                           (request-headers request))])
124       
125       ;; print request information
126       (logger:printer logger 
127                       (make-log-msg (msg-time-stamp)
128                                     'request-info 
129                                     request-info))
130       request)))
131
132