oxaliq.net/oxaliq.net.rkt

#lang racket

(require racket/date
         (only-in racket/list first second third rest)
         (only-in racket/string string-prefix? string-replace)
         net/url
         xml
         web-server/web-server
         web-server/servlet-dispatch
         web-server/dispatchers/dispatch
         web-server/dispatch
         (prefix-in files: web-server/dispatchers/dispatch-files)
         (prefix-in filter: web-server/dispatchers/dispatch-filter)
         (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
         racket/runtime-path
         web-server/dispatchers/filesystem-map
         web-server/http
         csv-reading)

;; namespace needed for evaluating read files
(define-namespace-anchor anc)
(define ns (namespace-anchor->namespace anc))

;; it's all html!
(define (html-response content)
  (response/full
   200
   #"OK"
   (current-seconds)
   TEXT/HTML-MIME-TYPE
   '()
   (list content)))

;; bound path builders
;; extension is always #".scm" because source files are not racket,
;; but must be read and evaluated in this namespace
(define (make-path-no-param root-folder extension)
  (lambda (t)
    (path-add-extension
     (if (and (non-empty-string? t) (not (eq? t "root")))
         (build-path root-folder t "index")
         (build-path root-folder "index"))
     extension)))

(define (make-path-id-param root-folder extension)
  (lambda (t id)
    (path-add-extension
     (build-path root-folder
                 (if (eq? t "root")
                     (if (eq? id "")
                         ;; if "root/" something weird has happened
                         "index"
                         ;; allows for loading "/about" and other root resources
                         (~a id))
                     (if
                      ;; if url has trailing backslash, id will be an empty string
                      ;; and should return index for that type
                      (or (not (string? id))
                          (non-empty-string? id))
                      (build-path t (~a id))
                      (build-path t "index"))))
     extension)))

(define (make-source-path-no-param t)
  ((make-path-no-param "source" #".scm") t))

(define (make-source-path-id-param t id)
  ((make-path-id-param "source" #".scm") t id))

(define (make-static-path-no-param api-type t)
  (let ([root-folder 
         (cond
           [(eq? api-type 'httpx) "static/fragment"]
           [(eq? api-type 'page) "static/page"]
           [else (error "api-type ~a not recognized" api-type)])])
    ((make-path-no-param root-folder #".html") t)))

(define (make-static-path-id-param api-type t id)
  (let ([root-folder 
         (cond
           [(eq? api-type 'httpx) "static/fragment"]
           [(eq? api-type 'page) "static/page"]
           [else (error "api-type ~a not recognized" api-type)])])
    ((make-path-id-param root-folder #".html") t id)))



(define (static-file-res static-path)
  (string->bytes/utf-8 (file->string static-path)))

;; wrapper for resource-processor
(define (wrapper-for-resource-processor static-path res-processor)
  (if (not (file-exists? static-path))
      (html-response (static-file-res static-path))
      (res-processor)))

;; write static-file
;; return data that was written
(define (write-static-file static-path)
  (lambda (data)
    (let ([out-port (open-output-file static-path #:exists 'error)])
      (if (port-try-file-lock? out-port 'exclusive)
          (begin
            (display data out-port)
            (port-file-unlock out-port)
            (close-output-port out-port)
            data)
          (error "couldn't obtain file lock on ~a" out-port)))))
                                                                    

(define (404-handler api-type)
  (cond
    [(eq? api-type 'httpx) (404-hx)]
    [(eq? api-type 'page) (404-page)]
    [else (error "api-type ~a not recognized" api-type)]))


;; takes a resource-type (corresponds to the REST resource and the system path or
;; an index resource in the source path)
;; and a resource-processor (-> file-handle . http-response)
;; and returns a valid html-response irrespective of hx/ type fragment of html or full page
(define respond-resource-with-processor 
  (lambda (api-type res-type resource-processor)
    ;; this lambda will be called by dispatch-rules
    ;; (req) is the request object
    (case-lambda
      [(req)
       (let ([static-path (make-static-path-no-param api-type res-type)])
         (if (file-exists? static-path)
             (html-response (static-file-res static-path))
             (let ([res-path (make-source-path-no-param res-type)])
               (if (file-exists? res-path)
                   (html-response
                    (resource-processor res-path (write-static-file static-path)))
                   (404-handler api-type)))))]
      ;; (req id) is (request object . url parameter)
      [(req id)
       (let ([static-path (make-static-path-id-param api-type res-type id)])
         (if (file-exists? static-path)
             (html-response (static-file-res static-path))
             (let ([res-path (make-source-path-id-param res-type id)])
               (if (file-exists? res-path)
                   (html-response (resource-processor res-path (write-static-file static-path)))
                   (404-handler api-type)))))])))
;;; httpx
;; sends only the requested resource
(define (xexpr-file->res file static-write)
  (string->bytes/utf-8
   (static-write (xexpr-file->xml file))))

(define (xexpr-file->xml file)
  (xexpr->string (read (open-input-file file))))

(define (404-hx)
  (let ([static-path "static/fragment/not-found.html"])
    (html-response
     (if (file-exists? static-path)
         (static-file-res static-path)
         (xexpr-file->res "source/not-found.scm" (write-static-file static-path))))))


(define-values (httpx-app reverse-httpx-uri)
  (dispatch-rules
   [("hx" "home") (respond-resource-with-processor 'httpx "root" xexpr-file->res)]
   [("hx" "settled") (respond-resource-with-processor 'httpx "settled" xexpr-file->res)]
   [("hx" "settled" (string-arg)) (respond-resource-with-processor 'httpx "settled" xexpr-file->res)]
   [("hx" "unsettled") (respond-resource-with-processor 'httpx "unsettled" xexpr-file->res)]
   [("hx" "unsettled" (string-arg)) (respond-resource-with-processor 'httpx "unsettled" xexpr-file->res)]
   [("hx" "tagged") (respond-resource-with-processor 'httpx "tagged" xexpr-file->res)]
   [("hx" "tagged" (string-arg)) (respond-resource-with-processor 'httpx "tagged" xexpr-file->res)]
   [("hx" (string-arg)) (respond-resource-with-processor 'httpx "root" xexpr-file->res)]
   [else (lambda (req) (404-hx))]))

;;; page-app
;; constructs entire page for each response
(define (make-page resource static-write)
  (string->bytes/utf-8
   (static-write
    (string-append
     "<!DOCTYPE html>\n"
     (fragment->page resource)))))

(define (fragment->page resource)
  (xexpr->string
    `(html ((lang "en"))
           ,(read (open-input-file "source/head.scm"))
           (body
            ,(read (open-input-file "source/header.scm"))
            (main ,(read (open-input-file resource)))))))

(define (404-page)
  (let ([static-path "static/page/not-found.html"])
    (html-response
     (if (file-exists? static-path)
         (static-file-res static-path)
         (make-page "source/not-found.scm" (write-static-file static-path))))))

(define-values (page-app reverse-page-uri)
  (dispatch-rules
   [("") (respond-resource-with-processor 'page "" make-page)]
   [("home") (respond-resource-with-processor 'page  "" make-page)]
   [("settled") (respond-resource-with-processor 'page  "settled" make-page)]
   [("settled" (string-arg)) (respond-resource-with-processor 'page "settled" make-page)]
   [("unsettled") (respond-resource-with-processor 'page "unsettled" make-page)]
   [("unsettled" (string-arg)) (respond-resource-with-processor 'page  "unsettled" make-page)]
   [("tagged") (respond-resource-with-processor 'page "tagged" make-page)]
   [("tagged" (string-arg)) (respond-resource-with-processor 'page "tagged" make-page)]
   [((string-arg)) (respond-resource-with-processor 'page "root" make-page)]
   [else (lambda (req) (404-page))]))
   
  

;;; from /static
(define url->path/static (make-url->path "static"))

(define static-dispatcher
  (files:make #:url->path (lambda (u)
                            (url->path/static
                             (struct-copy url u [path (cdr (url-path u))])))))

;; rss feed
(define (xml-response content)
  (response/full
   200
   #"OK"
   (current-seconds)
   #"application/atom+xml; charset=utf-8"
   '()
   (list content)))


(define (rss-feed request)
    (xml-response
     (string->bytes/utf-8 (file->string "source/feed.atom"))))


;;; 404
(define (not-found request)
  (lambda (req) ((404-page))))

;;; server
(define stop
  (serve
   #:dispatch (sequencer:make
               (filter:make #rx"^/static/" static-dispatcher)
               (dispatch/servlet #:regexp #rx"^/hx/" httpx-app)
               (dispatch/servlet #:regexp #rx"^/feed.atom" rss-feed)
               (dispatch/servlet page-app)
               (dispatch/servlet not-found))
   #:listen-ip "127.0.0.1"
   #:port 8000))

(with-handlers ([exn:break? (lambda (e)
                              (stop))])
  (sync/enable-break never-evt))