Welcome to the CHICKEN Scheme pasting service

spiffy-server added by dieggsy on Fri Jul 12 17:12:20 2019

#!/usr/bin/chicken-csi -s
(import spiffy
        cgi-handler
        uri-common
        intarweb
        (only chicken.format format)
        (only chicken.string  string-split string-intersperse ->string)
        (only chicken.file file-exists? directory)
        (only chicken.pathname
              make-pathname pathname-extension
              pathname-file pathname-directory)
        (only chicken.tcp tcp-listen tcp-accept)
        (only chicken.io read-line)
        (only chicken.sort sort)
        (only srfi-13 string-join string-null?)
        (only srfi-18 thread-start!)
        (only openssl
              ssl-listen* ssl-accept
              ssl-load-certificate-chain! ssl-load-private-key!)
        (only matchable match)
        (only nrepl nrepl nrepl-loop)
        (only inotify init! clean-up! add-watch! next-events!))

;; TODO: favicon
(spiffy-group "http")
(spiffy-user "http")
(root-path "/srv/http/dieggsy-domains")

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

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

(define ssl-listener
  (ssl-listen* port: 443
               certificate:  "/etc/letsencrypt/live/dieggsy.com/fullchain.pem"
               private-key:  "/etc/letsencrypt/live/dieggsy.com/privkey.pem"))
(define http-listener (tcp-listen 80))

;; (ssl-load-certificate-chain! ssl-listener "/etc/letsencrypt/live/dieggsy.com/fullchain.pem")
;; (ssl-load-private-key! ssl-listener "/etc/letsencrypt/live/dieggsy.com/privkey.pem")

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

;; Don't serve org files, these are internal to generate html
(file-extension-handlers
 `(("org" . ,(lambda (p) (handle-not-found p)))))

(handle-not-found
 (lambda (path)
   (send-status 'not-found
                "

There seems to be nothing here!

"))) ;; TODO: Modularize this per website? (define (make-generic-handler root fn) (lambda (continue) (let* ((req (current-request)) (uri (request-uri req)) (path (uri-path uri)) (scheme (uri-scheme uri))) (if (eqv? scheme 'http) (match path ;; Handle let's encrypt certs (('/ ".well-known" "acme-challenge" . rest) (parameterize ((root-path root)) (continue))) ;; Redirect to https (else (let ((new-u (update-uri uri scheme: 'https))) (with-headers `((location ,new-u)) (lambda () (send-status 'moved-permanently)))))) ;; HTTPS (match path (('/ (and subdir (or "css" "image" "js")) filename) (continue)) (else (fn continue root uri))))))) (define (blog-fn continue root uri) (match (uri-path uri) (('/ (and subdir (or "prime" "fibonacci")) nth) (parameterize ((root-path root)) (send-static-file (make-pathname "fun" subdir "html")))) (else (parameterize ((root-path root)) (continue))))) (define (paste-fn continue root uri) (match (uri-path uri) ;; TODO (('/ (or "" "pastes.html")) (parameterize ((root-path root)) (continue))) (('/ title . raw) (let* ((raw? (and (not (null? raw)) (car raw))) (subdir (if raw? "raw" "html")) (ext (if raw? "txt" "html")) (fname (make-pathname #f title ext)) (new-path `(/ ,subdir ,fname)) (new-uri (update-uri uri path: new-path))) (parameterize ((root-path root) (current-request (update-request (current-request) uri: new-uri))) (continue)))))) (define (wiki-fn continue root uri) (parameterize ((root-path root)) (continue))) (define handle-blog (make-generic-handler "/srv/http/dieggsy-domains/blog" blog-fn)) (define handle-paste (make-generic-handler "/srv/http/dieggsy-domains/paste" paste-fn)) (define handle-wiki (make-generic-handler "/srv/http/dieggsy-domains/wiki" wiki-fn)) (define (handle-cgit continue) (parameterize ((root-path "/srv/git") (handle-directory cgit) (handle-not-found (lambda (p) (let* ((uri (request-uri (current-request))) (path (string-intersperse (cdr (uri-path uri)) "/"))) (parameterize ((current-pathinfo (string-split path "/"))) (cgit path)))))) (continue))) (vhost-map `(("dieggsy.com" . ,(lambda (c) (handle-blog c))) ("paste.dieggsy.com" . ,(lambda (c) (handle-paste c))) ("wiki.dieggsy.com" . ,(lambda (c) (handle-wiki c))) ("code.dieggsy.com" . ,(lambda (c) (handle-cgit c))) ("www.dieggsy.com" . ,(lambda (c) (let* ((old-u (request-uri (current-request))) (new-u (update-uri old-u host: "dieggsy.com"))) (with-headers `((location ,new-u)) (lambda () (send-status 'moved-permanently)))))))) ;; Watch for pastes - if a new one is created, re-generate the listing in ;; pastes.html (for paste.dieggsy.com homepage) (init!) (on-exit clean-up!) (add-watch! (make-pathname (root-path) "paste/raw") '(move create delete)) (define (watch-paste) (next-events!) (call-with-output-file (make-pathname (root-path) "paste/pastes" "html") (lambda (p) (display (string-join (map (lambda (f) (let ((f (pathname-file f))) (format "

~a

" f f))) (sort (directory (make-pathname (root-path) "paste/raw")) string>?)) "\n") p))) (watch-paste)) ;; Generate pastes homepage (thread-start! watch-paste) ;; Start on HTTP (thread-start! (lambda () (parameterize ((server-port 80)) (accept-loop http-listener tcp-accept)))) ;; Start on SSL (parameterize ((server-port 443)) (accept-loop ssl-listener ssl-accept))

Your annotation:

Enter a new annotation:

Your nick:
The title of your paste:
Your paste (mandatory) :
Which R5RS procedure can be used to concatenate strings?
Visually impaired? Let me spell it for you (wav file) download WAV