HomeAboutCodePastes
#!/usr/bin/chicken-csi -s
(import spiffy
        cgi-handler
        uri-common
        intarweb
        (only chicken.process-context.posix current-process-id)
        ;; (only chicken.process process-fork)
        (only chicken.format format)
        (only chicken.string  string-split string-intersperse)
        ;; (only chicken.file directory create-directory)
        (only chicken.pathname make-pathname pathname-file)
        (only chicken.tcp tcp-listen tcp-accept)
        (only chicken.io read-line)
        ;; (only chicken.sort sort)
        (only chicken.random random-bytes)
        (only srfi-13 string-join)
        (only srfi-18 thread-start!)
        (only openssl ssl-listen* ssl-accept)
        (only matchable match)
        (only nrepl nrepl nrepl-loop)
        ;; (only inotify init! clean-up! add-watch! next-events!)
        (only base64 base64-encode)
        (only sxml-serializer serialize-sxml))

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

(access-log (make-pathname (root-path) "debug/access.log"))
(error-log (make-pathname (root-path) "debug/error.log"))
(debug-log (make-pathname (root-path) "debug/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))

(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)))))

(define default-sxml-header
  '((link (@ (rel "stylesheet")
             (type "text/css")
             (href "./css/org.css")))
    (div (@ (align "right"))
         (a (@ (target "_self")
               (href "https://dieggsy.com"))
            "Home")
         (& 32) (& #x2212) (& 32)
         (a (@ (target "_self")
               (href "https://dieggsy.com/about.html"))
            "About")
         (& 32) (& #x2212) (& 32)
         (a (@ (target "_self")
               (href "https://code.dieggsy.com"))
            "Code")
         (& 32) (& #x2212) (& 32)
         (a (@ (target "_self")
               (href "https://paste.dieggsy.com"))
            "Pastes"))))

(handle-not-found
 (lambda (path)
   (send-response
    status: 'not-found
    body:
    (serialize-sxml
     `(,@default-sxml-header
        (h1 "Whoops")
        (p "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))
                      ;; Something to redirect to plaintext if html not found
                      ;; (handle-not-found (let ((old-handle (handle-not-found)))
                      ;;                     ()))
                      )
         (continue))))))

(define (wiki-fn continue root uri)
  (parameterize ((root-path root))
    (continue)))

(define handle-blog (make-generic-handler (make-pathname (root-path) "blog") blog-fn))
(define handle-paste (make-generic-handler (make-pathname (root-path) "paste") paste-fn))
(define handle-wiki (make-generic-handler (make-pathname (root-path) "wiki") wiki-fn))
(define (handle-cgit continue)
  (parameterize
      ((root-path "/usr/share/webapps/cgit")
       (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)
;; (process-fork
;;  (lambda ()
;;    (init!)
;;    (on-exit clean-up!)
;;    (create-directory (make-pathname (root-path) "paste"))
;;    (add-watch! (make-pathname (root-path) "paste/raw") '(move create delete))
;;    (let watch-paste ()
;;      (next-events!)
;;      (call-with-output-file (make-pathname (root-path) "paste/index" "html")
;;        (lambda (p)
;;          (display (serialize-sxml `(,@default-sxml-header
;;                                      (h1 "diego's pastes"))) p)
;;          (newline p)
;;          (for-each
;;           (lambda (f)
;;             (let ((f (pathname-file f)))
;;               ;; (format p "<h2><a href=\"~a\">~a</a></h2>~n" f f)
;;               (display (serialize-sxml  `(p (a (@ (href ,f)) ,f))) p)
;;               (newline p)))
;;           (sort (directory (make-pathname (root-path) "paste/raw")) string>?))))
;;      (watch-paste))))

;; Initialize nrepl
(define token (base64-encode (random-bytes (make-string 20))))

(call-with-output-file "/tmp/nrepl-token"
  (cut display token <>))

(thread-start!
 (lambda ()
   (nrepl 8081
          (lambda ()
            (thread-start! ;; otherwise accept-loop will be blocked
             (lambda ()
               (display "#;: ")
               (define input (read-line))
               (if (equal? input token)
                   (nrepl-loop)
                   (begin (print ";; access denied")
                          (close-input-port (current-input-port))
                          (close-output-port (current-output-port))
                          (close-output-port (current-error-port))))))))))

;; Start on HTTP
(thread-start! (lambda ()
                 (parameterize ((server-port 80))
                   (accept-loop http-listener tcp-accept))))

(call-with-output-file (make-pathname (root-path) "debug/main-server-pid.txt")
  (cut display (current-process-id) <>))

;; Start on SSL
(parameterize ((server-port 443))
  (accept-loop ssl-listener ssl-accept))

plain