Welcome to the CHICKEN Scheme pasting service

#!/usr/bin/csi -s

(use data-structures cgi-handler intarweb matchable posix spiffy spiffy-directory-listing
     srfi-18 openssl tcp6 uri-common)

(define cgit (cgi-handler* "/usr/share/webapps/cgit/cgit.cgi"))

(define (expire-1hour k)
  (with-headers `((expires ,(vector (seconds->utc-time (+ (current-seconds) 3600)) '())))
    k))

(define (redirect-host host)
  (lambda (continue)
       (let* ((old-u (request-uri (current-request)))
              (new-u (update-uri old-u host: host)))
         (with-headers `((location ,new-u))
           (lambda () (send-status 'moved-permanently))))))

(define (subdomain-root domain)
  (let ((path-prefix (string-append docroot domain "/")))
    (lambda (continue)
      (let ((host (string-split (uri-host (request-uri (current-request))) ".")))
        (parameterize ((root-path (string-append path-prefix (car host))))
          (expire-1hour continue))))))

;; Activate TCP buffering
(tcp-buffer-size 2048)

(spiffy-user "http")
(spiffy-group "http")

(define normal-port 80)
(define ssl-port 443)

(define normal-listener (tcp-listen normal-port 10 "::"))
(define ssl-listener (ssl-listen ssl-port 10 "::" 'tlsv12))
(ssl-load-certificate-chain! ssl-listener "cert.pem")
(ssl-load-private-key! ssl-listener "cert.key")

(switch-user/group (spiffy-user) (spiffy-group))

(access-log "/var/log/spiffy/access.log")
(error-log "/var/log/spiffy/error.log")
;; (debug-log "/var/log/spiffy/debug.log")

(mime-type-map
 '(("html" . #(text/html ((charset . utf-8))))
   ("xhtml" . #(application/xhtml+xml ((charset . utf-8))))
   ("js" . #(application/javascript ((charset . utf-8))))
   ("css" . #(text/css ((charset . utf-8))))
   ("png" . image/png)
   ("xml" . #(application/xml ((charset . utf-8))))
   ("pdf" . application/pdf)
   ("jpeg" . image/jpeg)
   ("jpg" . image/jpeg)
   ("gif" . image/gif)
   ("ico" . image/vnd.microsoft.icon)
   ("svg" . #(image/svg+xml ((charset . utf-8))))
   ("txt" . #(text/plain ((charset . utf-8))))
   ("atom" . #(application/atom+xml ((charset . utf-8))))
   ("flac" . audio/x-flac)
   ("mp3" . audio/mpeg)
   ("mp4" . video/mp4)
   ("ogg" . application/ogg)
   ("oga" . application/ogg)
   ("ogv" . application/ogg)
   ("wav" . audio/x-wav)
   ("webm" . video/webm)))

(index-files
 '("index.xhtml" "index.html" "index.xml" "index.svg" "index.txt"))

(define docroot "/srv/http/")

;; Default root for unknown domains
(root-path (string-append docroot "unknown"))

(handle-directory spiffy-directory-listing)

(vhost-map
 `(((: bos "upyum.com" eos) . ,(redirect-host "www.upyum.com"))
   ((: bos "gaufr.es" eos) . ,(redirect-host "www.gaufr.es"))
   ((: bos "reptifur.fr" eos) . ,(redirect-host "repti.fr"))
   ((: bos "repti.fr" eos) . ,(lambda (k) (root-path (string-append docroot "repti.fr")) (expire-1hour k)))
   ((: bos "www.upyum.com" eos) . ,(lambda (k)
                                     (let* ((req (current-request))
                                            (uri (request-uri req))
                                            (path (uri-path uri))
                                            (hdrs (request-headers req))
                                            (accept-languages (header-value 'accept-language hdrs)))
                                       (match path
                                         ('(/ "")
                                          (with-headers `((location ,(update-uri uri path: (list '/ (if (memq accept-languages '(fr fr-be fr-ca fr-ch fr-fr fr-lu fr-mc)) "fr" "en")))))
                                            (lambda () (send-status 'moved-permanently))))
                                         (('/ "cgit.cgi" . rest)
                                          (parameterize ((current-pathinfo rest))
                                            (cgit "")))
                                         (else
                                          (parameterize ((root-path (string-append docroot "upyum.com/www")))
                                            (expire-1hour k)))))))
   ((: bos "hg.upyum.com" eos) . ,(lambda (k)
                                    (with-headers `((location ,(update-uri (request-uri (current-request))
                                                                           host: "www.upyum.com"
                                                                           path: '(/ "cgit.cgi"))))
                                      (lambda () (send-status 'moved-permanently)))))
   ((: bos "kooda.upyum.com" eos) . ,(lambda (k)
                                       (let ((uri (request-uri (current-request))))
                                         (if (equal? '(/ "") (uri-path uri))
                                             (with-headers `((location ,(update-uri uri host: "www.upyum.com")))
                                               (lambda () (send-status 'moved-permanently)))
                                             (parameterize ((root-path (string-append docroot "upyum.com/kooda"))) (expire-1hour k))))))
   ((: bos (+ any) ".upyum.com" eos) . ,(subdomain-root "upyum.com"))
   ((: bos (+ any) ".gaufr.es" eos) . ,(subdomain-root "gaufr.es"))))

(define normal-thread
  (make-thread
   (lambda ()
     (server-port normal-port)
     (accept-loop normal-listener tcp-accept tcp-addresses))))

(define ssl-thread
  (make-thread
   (lambda ()
     (server-port ssl-port)
     (accept-loop ssl-listener ssl-accept (lambda (port) (tcp-addresses (ssl-port->tcp-port port)))))))

(thread-start! normal-thread)
(thread-start! ssl-thread)

(print "server started!")

(thread-join! normal-thread)