artanis.scm 11.2 KB
Newer Older
Nala Ginrut's avatar
Nala Ginrut committed
1
;;  -*-  indent-tabs-mode:nil; coding: utf-8 -*-
Nala Ginrut's avatar
Nala Ginrut committed
2
;;  Copyright (C) 2013,2014,2015,2016,2017,2018,2019,2020
Nala Ginrut's avatar
Nala Ginrut committed
3 4
;;      "Mu Lei" known as "NalaGinrut" <[email protected]>
;;  Artanis is free software: you can redistribute it and/or modify
Nala Ginrut's avatar
Nala Ginrut committed
5 6 7 8
;;  it under the terms of the GNU General Public License and GNU
;;  Lesser General Public License published by the Free Software
;;  Foundation, either version 3 of the License, or (at your option)
;;  any later version.
Nala Ginrut's avatar
Nala Ginrut committed
9 10 11 12

;;  Artanis 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
Nala Ginrut's avatar
Nala Ginrut committed
13 14
;;  GNU General Public License and GNU Lesser General Public License
;;  for more details.
Nala Ginrut's avatar
Nala Ginrut committed
15 16

;;  You should have received a copy of the GNU General Public License
Nala Ginrut's avatar
Nala Ginrut committed
17 18
;;  and GNU Lesser General Public License along with this program.
;;  If not, see <http://www.gnu.org/licenses/>.
Nala Ginrut's avatar
Nala Ginrut committed
19 20

(define-module (artanis artanis)
NalaGinrut's avatar
NalaGinrut committed
21
  #:use-module (artanis utils)
Nala Ginrut's avatar
Nala Ginrut committed
22
  #:use-module (artanis config)
Nala Ginrut's avatar
Nala Ginrut committed
23
  #:use-module (artanis env)
Nala Ginrut's avatar
Nala Ginrut committed
24
  #:use-module (artanis tpl)
Nala Ginrut's avatar
Nala Ginrut committed
25
  #:use-module (artanis db)
26
  #:use-module (artanis fprm)
Nala Ginrut's avatar
Nala Ginrut committed
27
  #:use-module (artanis ssql)
28
  #:use-module (artanis session)
Nala Ginrut's avatar
Nala Ginrut committed
29 30 31 32
  #:use-module (artanis oht)
  #:use-module (artanis route)
  #:use-module (artanis page)
  #:use-module (artanis upload)
33
  #:use-module (artanis debug)
Nala Ginrut's avatar
Nala Ginrut committed
34 35
  #:use-module (artanis third-party csv)
  #:use-module (artanis third-party json)
36
  #:use-module (artanis server)
Nala Ginrut's avatar
Nala Ginrut committed
37
  #:use-module (artanis cache)
Nala Ginrut's avatar
Nala Ginrut committed
38
  #:use-module (artanis websocket)
Nala Ginrut's avatar
Nala Ginrut committed
39
  #:use-module (artanis lpc)
Nala Ginrut's avatar
Nala Ginrut committed
40
  #:use-module (artanis version)
NalaGinrut's avatar
NalaGinrut committed
41
  #:use-module (web server)
Nala Ginrut's avatar
Nala Ginrut committed
42
  #:use-module (srfi srfi-1)
Nala Ginrut's avatar
Nala Ginrut committed
43
  #:use-module (ice-9 format)
Nala Ginrut's avatar
Nala Ginrut committed
44 45 46 47
  #:re-export (;; env
               http-status

               ;; page module
Nala Ginrut's avatar
Nala Ginrut committed
48 49 50 51 52 53 54 55
               response-emit
               throw-auth-needed
               tpl->html
               redirect-to
               tpl->response
               reject-method
               run-after-request!
               run-before-response!
Joe Dong's avatar
Joe Dong committed
56
               run-when-sigint!
Nala Ginrut's avatar
Nala Ginrut committed
57 58
               emit-response-with-file
               static-page-emitter
Nala Ginrut's avatar
Nala Ginrut committed
59 60 61 62 63 64

               ;; oht module
               get
               post
               put
               patch
65
               page-options
Nala Ginrut's avatar
Nala Ginrut committed
66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81
               page-delete
               :sql-mapping
               :str
               :conn
               :raw-sql
               :cookies
               :cache
               :cookies-set!
               :cookies-ref
               :cookies-update!
               :cookies-remove!
               :cookies-setattr!
               :mime
               :auth
               :session
               :from-post
82
               :websocket
Nala Ginrut's avatar
Nala Ginrut committed
83
               :lpc
Nala Ginrut's avatar
Nala Ginrut committed
84 85 86 87 88 89 90 91 92

               ;; db module
               DB-open
               DB-close
               DB-query
               DB-result-status
               DB-get-all-rows
               DB-get-top-row
               DB-get-n-rows
93
               db-conn-success?
Nala Ginrut's avatar
Nala Ginrut committed
94
               init-DB
95 96 97
               connect-db
               make-<connection>
               <connection>?
Nala Ginrut's avatar
Nala Ginrut committed
98
               current-connection
99 100 101 102 103 104 105

               ;; fprm module
               map-table-from-DB
               make-table-getter
               make-table-setter
               make-table-builder
               make-table-dropper
Nala Ginrut's avatar
Nala Ginrut committed
106 107 108 109

               ;; ssql module
               ->sql
               where
Nala Ginrut's avatar
Nala Ginrut committed
110 111
               having
               /in
Nala Ginrut's avatar
Nala Ginrut committed
112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128
               /or
               /and

               ;; route module
               rc-handler rc-handler!
               rc-keys rc-keys!
               rc-re rc-re!
               rc-req rc-req!
               rc-path rc-path!
               rc-qt rc-qt!
               rc-method rc-method!
               rc-rhk rc-rhk!
               rc-bt rc-bt!
               rc-body rc-body!
               rc-mtime rc-mtime!
               rc-cookie rc-cookie!
               rc-set-cookie rc-set-cookie!
Nala Ginrut's avatar
Nala Ginrut committed
129
               rc-oht rc-oht!
130 131 132
               rc-conn rc-conn!
               new-route-context
               route-context?
Nala Ginrut's avatar
Nala Ginrut committed
133
               get-header
Nala Ginrut's avatar
Nala Ginrut committed
134
               get-from-qstr
135
               get-referer
Nala Ginrut's avatar
Nala Ginrut committed
136
               params
Nala Ginrut's avatar
Nala Ginrut committed
137

Nala Ginrut's avatar
Nala Ginrut committed
138 139 140 141 142 143 144 145
               ;; csv
               make-csv-reader
               csv->xml
               sxml->csv
               csv-write
               sxml->csv-string

               ;; json
Nala Ginrut's avatar
Nala Ginrut committed
146
               ->json-string
Nala Ginrut's avatar
Nala Ginrut committed
147 148 149 150 151 152
               scm->json
               scm->json-string
               json->scm
               json-string->scm
               json-parser?
               json-parser-port
Nala Ginrut's avatar
Nala Ginrut committed
153

Nala Ginrut's avatar
Nala Ginrut committed
154 155 156 157 158
               ;; upload
               mfd-simple-dump
               make-mfd-dumper
               content-type-is-mfd?
               mfd
Nala Ginrut's avatar
Nala Ginrut committed
159 160
               call-with-mfd-data
               find-mfd
Nala Ginrut's avatar
Nala Ginrut committed
161
               make-mfd
Nala Ginrut's avatar
Nala Ginrut committed
162 163
               mfd?
               is-mfds?
Nala Ginrut's avatar
Nala Ginrut committed
164 165 166
               mfd-dispos
               mfd-name
               mfd-filename
Nala Ginrut's avatar
Nala Ginrut committed
167 168
               mfd-begin
               mfd-end
Nala Ginrut's avatar
Nala Ginrut committed
169 170 171
               mfd-type
               mfd-simple-dump-all
               store-uploaded-files
Nala Ginrut's avatar
Nala Ginrut committed
172 173
               upload-files-to

Nala Ginrut's avatar
Nala Ginrut committed
174 175 176 177 178
               ;; cache
               try-to-get-page-from-cache
               cache-this-page
               clear-content-cache

179
               ;; websocket
180
               named-pipe-subscribe
181

Nala Ginrut's avatar
Nala Ginrut committed
182 183 184
               ;; server
               schedule-task

Nala Ginrut's avatar
Nala Ginrut committed
185 186
               ;; version
               artanis-version)
Nala Ginrut's avatar
Nala Ginrut committed
187
  #:export (result-ref
Nala Ginrut's avatar
Nala Ginrut committed
188
            init-server
Nala Ginrut's avatar
Nala Ginrut committed
189 190 191 192 193
            form-tag
            label-tag
            a-tag
            p-tag
            div-tag
Nala Ginrut's avatar
Nala Ginrut committed
194 195 196 197 198 199
            run))

(define* (result-ref alst key #:key (decode? #t))
  (and=> (assoc-ref alst key) (if decode? uri-decode identity)))

(define (default-route-init statics cache-statics? exclude)
Nala Ginrut's avatar
Nala Ginrut committed
200
  ;; avoid a common warn
Nala Ginrut's avatar
Nala Ginrut committed
201
  (get "/" #:cache #t (lambda () "no index.html but it works!"))
Nala Ginrut's avatar
Nala Ginrut committed
202
  (let ((srule (format #f "^/.+\\.(~{~a~^|~})$" (lset-difference eq? statics exclude))))
Nala Ginrut's avatar
Nala Ginrut committed
203
    (if cache-statics?
Nala Ginrut's avatar
Nala Ginrut committed
204
        (get srule #:cache '(static) (lambda (rc) (:cache rc)))
Nala Ginrut's avatar
Nala Ginrut committed
205
        (get srule static-page-emitter))))
Nala Ginrut's avatar
Nala Ginrut committed
206

207
(define (check-invalid-config)
208 209
  (when (and (not (linux-version>=? "3.9")) (get-conf '(server multi)))
    (error "It's required to have Linux-3.9+ to enable server.multi feature!")))
210

Nala Ginrut's avatar
Nala Ginrut committed
211
;; make sure to call init-server at the beginning
Nala Ginrut's avatar
Nala Ginrut committed
212 213 214 215
(define* (init-server #:key (statics '(png jpg jpeg ico html js css))
                      (cache-statics? #f) (exclude '()))
  (default-route-init statics cache-statics? exclude)
  (init-hook)
216
  (init-config)
Nala Ginrut's avatar
Nala Ginrut committed
217
  (init-lpc)
218
  (check-invalid-config)
Nala Ginrut's avatar
Nala Ginrut committed
219
  (sigaction SIGPIPE SIG_IGN) ; surpass SIGPIPE signal since we want to handle EPIPE by self
220 221 222
  (sigaction SIGINT (lambda (i)
                      (run-when-sigint-hook)
                      (format (artanis-current-output)
Nala Ginrut's avatar
Nala Ginrut committed
223
                              "~%Fare you well, your server is cold.~%")
224
                      (quit)))
225
  (set! is-init-server-run? #t))
Nala Ginrut's avatar
Nala Ginrut committed
226

Nala Ginrut's avatar
Nala Ginrut committed
227 228 229 230
(define* (form-tag #:key (controller #f) (action #f) (method #f)
                   (class #f) (tag-class #f) (tag-id #f) (form-method "get"))
  (lambda tags
    (call-with-output-string
Nala Ginrut's avatar
Nala Ginrut committed
231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246
      (lambda (port)
        (format port "<form accept-charset='~a'" (get-conf '(server charset)))
        (format port " action='~a'"
                (call-with-output-string
                  (lambda (port2)
                    (display "/" port2)
                    (and controller (format port2 "~a/" controller))
                    (and action (format port2 "~a?" action))
                    (and method (format port2 "method=~a" method))
                    (and class (format port2 "&class=~a" class)))))
        (format port " method='~a'" method)
        (and tag-class (format port " class='~a'" tag-class))
        (and tag-id (format port " id='~a'" tag-id))
        (display ">\n" port)
        (for-each (lambda (tag) (format port "~a~%" tag)) tags)
        (format port "</form>~%")))))
Nala Ginrut's avatar
Nala Ginrut committed
247 248 249 250 251

(define (make-general-tag tag)
  (lambda attrs
    (lambda (contents)
      (call-with-output-string
Nala Ginrut's avatar
Nala Ginrut committed
252 253 254 255 256 257 258 259 260 261 262 263
        (lambda (port)
          (format port "<~a" tag)
          (let lp((next attrs))
            (cond
             ((null? next)
              (display ">\n" port)
              (display contents port)
              (newline port)
              (format port "</~a>" tag))
             (else
              (format port " ~a='~a'" (keyword->symbol (car next)) (cadr next))
              (lp (cddr attrs))))))))))
Nala Ginrut's avatar
Nala Ginrut committed
264 265 266 267 268 269

(define label-tag (make-general-tag 'label))
(define a-tag (make-general-tag 'a))
(define p-tag (make-general-tag 'p))
(define div-tag (make-general-tag 'div))

270
(define (debug-mode:file-monitoring rc body)
271 272 273 274
  (reload-monitored-files))

(define (init-debug-mode)
  (conf-set! 'debug-mode #t)
275 276 277 278 279 280 281 282
  (cond
   ((current-toplevel)
    ;; NOTE: If (current-toplevel) is #f, then it means you're not running under
    ;;       application folder, then the file monitoring feature is disabled automatically.
    (init-debug-monitor)
    (run-after-request! debug-mode:file-monitoring))
   (else (format (artanis-current-output)
                 "[WARN] You're not in application folder, the file motoring is disabled!~%"))))
283

Nala Ginrut's avatar
Nala Ginrut committed
284
;; Invalid use-db? must be (dbd username passwd) or #f
Nala Ginrut's avatar
Nala Ginrut committed
285
(define* (run #:key (host #f) (port #f) (debug #f) (use-db? #f) (db-proto #f) (server #f)
286
              (dbd #f) (db-username #f) (db-passwd #f) (db-name #f) (db-addr #f))
Nala Ginrut's avatar
Nala Ginrut committed
287 288 289 290 291 292 293 294 295 296
  (define (->proper-body-display body)
    (cond
     ((not body) "No body in the request!")
     ((string? body)
      (if debug
          body
          (substring body
                     (and=> (string-length body)
                            (lambda (len) (if (> len 100) 100 len))))))
     (((@ (rnrs bytevectors) bytevector?) body) "Body is bytevectors!")
Nala Ginrut's avatar
Nala Ginrut committed
297 298 299 300
     ((websocket-frame? body)
      (if debug
          (print-websocket-frame body)
          "<websocket-frame>"))
Nala Ginrut's avatar
Nala Ginrut committed
301
     (else (throw 'artanis-err 500 ->proper-body-display "Invalid body type `~a'!" body))))
302
  (when (not is-init-server-run?)
Nala Ginrut's avatar
Nala Ginrut committed
303 304 305
    (error "Sorry, but you have to run (init-server) in the begining of you main program!"))
  (and host (conf-set! '(host addr) host))
  (and port (conf-set! '(host port) port))
Nala Ginrut's avatar
Nala Ginrut committed
306 307
  (and server (conf-set! '(server engine) (string->symbol server)))
  (init-server-core)
Nala Ginrut's avatar
Nala Ginrut committed
308 309
  (when debug
    (display "DEBUG: ON\n")
310
    (init-debug-mode))
311 312
  (when (or use-db? (get-conf '(db enable)))
    (conf-set! '(db enable) #t)
313
    (display "User wants to use Database, initializing...\n")
314
    (init-database-config dbd db-username db-passwd db-name db-addr db-proto)
Nala Ginrut's avatar
Nala Ginrut committed
315
    (init-DB)
316 317
    (display "DB init done!\n")
    (when (eq? 'db (get-conf '(session backend)))
Nala Ginrut's avatar
Nala Ginrut committed
318 319
      (session-init)
      (display "Session with DB backend init done!\n")))
320
  (case (get-conf '(session backend))
321
    ((db)
322
     (when (not (get-conf '(db enable)))
Nala Ginrut's avatar
Nala Ginrut committed
323
       (error "Session with DB backend init failed because you didn't enable DB!")))
324
    (else
325
     (session-init)
Nala Ginrut's avatar
Nala Ginrut committed
326 327
     (format #t "Session with ~:@(~a~) backend init done!~%"
             (get-conf '(session backend)))))
328
  (run-hook *before-run-hook*)
Nala Ginrut's avatar
Nala Ginrut committed
329
  (format #t "Server core: ~a~%" (get-conf '(server engine)))
Nala Ginrut's avatar
Nala Ginrut committed
330
  (format #t "~a~%" (current-myhost))
Nala Ginrut's avatar
Nala Ginrut committed
331
  (format #t "Anytime you want to quit just try Ctrl+C, thanks!~%")
332
  (let ((handler (if debug
Nala Ginrut's avatar
Nala Ginrut committed
333
                     (lambda (r b . _)
334 335 336 337
                       (format #t "[Request] ~a~%[Body] ~a~%" r (->proper-body-display b))
                       (server-handler r b))
                     server-handler)))
    (establish-http-gateway handler)))