#!/usr/bin/chicken-csi -s
(import spiffy
        cgi-handler
        uri-common
        intarweb
        (only chicken.process process-fork)
        (only chicken.format format)
        (only chicken.string  string-split string-intersperse)
        (only chicken.file 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))

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

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

(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
                "<p>There seems to be nothing here!</p>")))

;; ;; 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 (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!)
   (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)
           (for-each
            (lambda (f)
              (let ((f (pathname-file f)))
                (format p "<h2><a href=\"~a\">~a</a></h2>~n" f f)))
            (sort (directory (make-pathname (root-path) "paste/raw")) string>?))))
     (watch-paste))
   (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))))))))))

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

plain