ADD: with-locale to fix the time string bug.
[glow:ragnarok.git] / ragnarok / main.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 main)
17   #:use-module (ragnarok env)
18   #:use-module (ragnarok server)
19   #:use-module (ragnarok config)
20   #:use-module (ragnarok version)
21   #:use-module (ragnarok threads)
22   #:use-module (ragnarok utils)
23   #:use-module (oop goops)
24   #:use-module (ice-9 getopt-long)
25   #:export (main)
26   )
27
28 (define ragnarok-env (make <env>))
29
30 (define *ragnarok-running-dir* "/var/log/ragnarok")
31 (define make-ragnarok-sys-file
32   (lambda (filename)
33     (string-append *ragnarok-running-dir* "/" filename)))
34 (define *ragnarok-lock-file* 
35   (make-ragnarok-sys-file "ragnarok.lock"))
36 (define *ragnarok-log-file* 
37   (make-ragnarok-sys-file "ragnarok.log"))
38 (define *ragnarok-err-log-file* 
39   (make-ragnarok-sys-file "ragnarok.err"))
40
41 (define (ragnarok-unlock)
42   (let ([lfp (open *ragnarok-lock-file* O_RDWR)])
43     (flock lfp LOCK_UN)
44     (close lfp))
45   (delete-file *ragnarok-lock-file*))
46
47 (define option-spec
48   '((version (single-char #\v) (value #f))
49     (help (single-char #\h) (value #f))
50     (config (single-char #\c) (value #f)) ;; specify config file
51     (server (single-char #\s) (value #f)) ;; specify sub-servers to start
52     ))
53
54 (define help-str
55   "
56 Ragnarok is a generic server written with GNU/Guile and C.
57 Ragnarok supports http/1.1 originally now. You may define your own protocol to Ragnarok by protobuf-r6rs(coming soon).
58
59 Usage: ragnarok [OPTIONS]...
60
61 --help -h: Show this screen.
62 --version -v: Show version.
63 --config -c: Specify config file.
64 --server -s: Specify sub-servers to start which delimited by ','.
65
66 Any bug/improve report will be appreciated.
67 Author: NalaGinrut@gmail.com
68 God bless hacking.\n
69 ")
70
71 (define version-str
72   (format #f 
73           "
74 ~a. 
75
76 Copyright (C) 2011-2012 Mu Lei known as \"NalaGinrut\" <NalaGinrut@gmail.com>
77 License LGPLv3+: GNU LGPL 3 or later <http://gnu.org/licenses/lgpl.html>.
78 Ragnarok is free software: you are free to change and redistribute it.
79 There is NO WARRANTY, to the extent permitted by law.
80
81 God bless hacking.~%"
82           *ragnarok-version*))
83
84 (define (ragnarok-terminate)
85   (kill (getpid) SIGTERM))
86
87 (define (show-help)
88   (display help-str)
89   (exit)
90   )
91
92 (define (show-version)
93   (display version-str)
94   (exit)
95   )
96
97 (define ragnarok-log-message
98   (lambda (message)
99     (let* ([lf (open-file *ragnarok-log-file* "a")]
100            [cgt (get-global-current-time)]
101            )
102       (if lf
103           (format lf "~a at ~a~%" message cgt))
104       (close lf)
105       )))
106
107 (define (ragnarok-kill-all-servers)
108   (let ([server-list (env:server-list ragnarok-env)])
109     (for-each (lambda (s-pair)
110                 (server:down (cdr s-pair)))
111               server-list)))
112
113 (define (ragnarok-terminate-environ)
114   ;; TODO: terminate environ
115   (ragnarok-kill-all-servers)
116   )
117
118 (define ragnarok-SIGHUP-handler
119   (lambda (msg)
120     (ragnarok-log-message "Ragnarok hangup!")
121     ;; TODO: deal with hangup
122     ))
123
124 (define ragnarok-SIGTERM-handler
125   (lambda (msg)
126     (ragnarok-log-message "Ragnarok exit!");
127     (ragnarok-terminate-environ)
128     (ragnarok-unlock)
129     (sync)
130     ;;(format #t "well~quit")
131     (exit)
132     ))
133
134 (define (signal-register)
135   (sigaction SIGCHLD SIG_IGN) ;; ignore child
136   (sigaction SIGTSTP SIG_IGN) ;; ignore tty signals
137   (sigaction SIGTTOU SIG_IGN) ;; 
138   (sigaction SIGTTIN SIG_IGN) ;;
139   (sigaction SIGPIPE SIG_IGN) ;; avoid thread to be killed when client breaks
140   (sigaction SIGHUP ragnarok-SIGHUP-handler) ;; catch hangup signal
141   (sigaction SIGTERM ragnarok-SIGTERM-handler) ;; catch kill signal
142   )
143
144 (define (ragnarok-server-start)
145   (let* ([snl (get-sub-server-name-list)]
146          [cnt (length snl)])
147     (let lp ([server-list '()] [rest snl])
148       (if (null? rest)
149           (begin
150             (set! (env:server-list ragnarok-env) server-list)
151             (let ([n (length server-list)])
152               (cond
153                ((> n 1)
154                 (format #t "~a sub-servers activated!~%" n))
155                ((= n 1)
156                 (format #t "~a sub-server activated!~%" n))
157                ((= n 0)
158                 (format #t "No sub-server activated!~%")))))
159           (let* ([sname (car rest)]
160                  [server (make <server> #:name sname)])
161             (server:print-start-info server)
162             (ragnarok-call-with-new-thread
163              (lambda ()
164                (server:run server)))
165             (lp (cons (cons sname server) server-list) (cdr rest)))))))
166
167 (define (display-startup-message)
168   (format #t "~a~%" version-str)
169   (newline)
170   (display "===================")
171   (newline)
172   (format #t "Ragnarok starting...~%")
173   (format #t "If you want to check the log, type ragnarok-show-[err/log]~%")
174   )
175
176 (define (show-subserver-info)
177   (let* ([snl (get-sub-server-name-list)]
178          [cnt (length snl)]
179          )
180     (format #t "Find ~a sub-servers from you machine:~%" cnt)
181     (for-each (lambda (sname)
182                 (format #t "[~a] " sname))
183               snl)
184     (newline)
185     ))
186
187 (define main
188   (lambda (args)
189     (let* ((options 
190             (getopt-long args option-spec))
191            (need-help?
192             (option-ref options 'help #f))
193            (need-version?
194             (option-ref options 'version #f))
195            (config-file
196             (option-ref options 'config "/etc/ragnarok/server.conf"))
197            (server-list
198             (option-ref options 'server #f))
199            )
200
201       (cond
202        (need-help? (show-help))
203        (need-version? (show-version)))
204       
205       ;; daemonize
206       (let ([i (ragnarok-fork)])
207         (cond
208          ((> i 0) (primitive-exit)) ;; exit parent
209          ((< i 0) (error "Ragnarok: fork error!")))
210         )
211
212       ;; print greeting message
213       (display-startup-message)
214
215       ;; child(daemon) continue
216       (setsid)
217
218       (if (not (file-exists? *ragnarok-running-dir*))
219           (mkdir *ragnarok-running-dir*))
220       (chdir *ragnarok-running-dir*)
221
222       ;; delete old err log file ,or it will mess up with old-old err log
223       (if (file-exists? *ragnarok-err-log-file*)
224           (delete-file *ragnarok-err-log-file*))
225       (if (file-exists? *ragnarok-log-file*)
226           (delete-file *ragnarok-log-file*))
227
228       (let* ([i (open "/dev/null" O_RDWR)]
229              [e (open *ragnarok-err-log-file* (logior O_CREAT O_RDWR))] 
230              [log (open *ragnarok-log-file* (logior O_CREAT O_RDWR))]
231              [lfp (open *ragnarok-lock-file* 
232                         (logior O_RDWR O_CREAT)
233                         #o640)])
234         
235         ;;(for-each close (iota 3)) ;; close all ports
236         (redirect-port i (current-input-port)) ;; stdin
237         (redirect-port log (current-output-port))
238         (redirect-port e (current-error-port)) ;; stderr
239         (umask 022)
240         
241         (if (< (port->fdes lfp) 0)
242             (begin
243               (display "Ragnarok: can not open/create lock file!\n")
244               (exit 2)))
245
246         (flock lfp LOCK_EX)
247         
248         (write (getpid) lfp)
249         (close lfp))
250
251       ;; TODO: signal handler register
252       (signal-register)
253
254       ;; TODO: overload cmd parameters to default parameters
255       ;;       #f for default ,otherwise overload it.
256         
257       ;; show the active subserver information
258       (show-subserver-info)
259       
260       (ragnarok-server-start)
261
262       ;; never quit
263       (eternal-loop)
264       )))
265
266 (define (eternal-loop)
267   (sleep 1000) ;; to avoid high cpu usage 
268   (eternal-loop))
269