oxaliq.net/sorrel.dev.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)
         web-server/dispatchers/filesystem-map
         web-server/http
         csv-reading)

(define-namespace-anchor anc)
(define ns (namespace-anchor->namespace anc))


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


;; 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 (type resource-processor)
    (case-lambda
    [(req) (let ([res-path (path-add-extension
                            (if (and (non-empty-string? type) (not (eq? type "root")))
                                (build-path "source" type "index")
                                (build-path "source" "index" ))
                            #".txt")])
             (displayln res-path)
             (if (file-exists? res-path)
                 (html-response (resource-processor res-path))
                 (html-response (resource-processor "source/not-found.txt"))))]
    [(req id) (let ([res-path
                     (path-add-extension
                      (build-path
                       "source"
                       (if (eq? type "root")
                           (if (eq? id "")
                               ;; if "root/" something weird has happened
                               "index"
                               ;; allows for loading "/this" and other root resources
                               (~a id))
                           (if
                            ;; if "type/" id will be an empty string
                            (or (not (string? id)) (non-empty-string? id))
                            (build-path type (~a id))
                            ;; and should return index for that type
                            (build-path type "index"))))
                      #".txt")])
                (if (file-exists? res-path)
                    (html-response (resource-processor res-path))
                    (html-response (resource-processor "source/not-found.txt"))))])))

;;; httpx
;; sends only the requested resource
(define (xexpr-file->xml file)
  (string->bytes/utf-8
   (xexpr->string (read (open-input-file file)))))

(define (build-index res)
  ;; get all the entries in res table
  ;; build index
  (let* ([table (csv->list (open-input-file
                                 (path-add-extension
                                   (build-path "data" res)
                                   #".csv")))]
         [make-index
          (read (open-input-file "data/make-index.txt"))]
         [index ((eval make-index ns) res (rest table))])
    (lambda (req)
      (if (equal? res "tagged")
          '()
          (html-response
           (string->bytes/utf-8
            (xexpr->string index)))))))

(define (404-hx request)
  (html-response (xexpr-file->xml "source/not-found.txt")))


(define-values (httpx-app reverse-httpx-uri)
  (dispatch-rules
   [("hx" "home") (respond-resource-with-processor "root" xexpr-file->xml)]
   [("hx" "settled") (build-index "settled")]
   [("hx" "settled" (integer-arg)) (respond-resource-with-processor "settled" xexpr-file->xml)]
   [("hx" "unsettled") (build-index "unsettled")]
   [("hx" "unsettled" (integer-arg)) (respond-resource-with-processor "unsettled" xexpr-file->xml)]
   [("hx" "tagged") (respond-resource-with-processor "tagged" xexpr-file->xml)]
   [("hx" "tagged" (string-arg)) (respond-resource-with-processor "tagged" xexpr-file->xml)]
   [("hx" (string-arg)) (respond-resource-with-processor "root" xexpr-file->xml)]
   [else 404-hx]))

;;; page-app
;; constructs entire page for each response
(define (make-page resource)
  (string->bytes/utf-8
   (xexpr->string
    `(html ((lang "en"))
           ,(read (open-input-file "source/head.txt"))
           (body
            ,(read (open-input-file "source/header.txt"))
            (main ,(read (open-input-file resource))))))))

(define-values (page-app reverse-page-uri)
  (dispatch-rules
   [("") (respond-resource-with-processor "" make-page)]
   [("home") (respond-resource-with-processor "" make-page)]
   [("settled") (respond-resource-with-processor "settled" make-page)]
   [("settled" (integer-arg)) (respond-resource-with-processor "settled" make-page)]
   [("unsettled") (respond-resource-with-processor "unsettled" make-page)]
   [("unsettled" (integer-arg)) (respond-resource-with-processor "unsettled" make-page)]
   [("tagged") (respond-resource-with-processor "tagged" make-page)]
   [("tagged" (string-arg)) (respond-resource-with-processor "tagged" make-page)]
   [((string-arg)) (respond-resource-with-processor "root" make-page)]
   [else not-found]))
   
  

;;; 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)
  (html-response (make-page "source/not-found.txt")))


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