108 lines
2.9 KiB
Scheme
108 lines
2.9 KiB
Scheme
|
(use-modules (htmlprag)
|
||
|
|
(logging logger)
|
||
|
|
(logging port-log)
|
||
|
|
((oop goops) #:select (make))
|
||
|
|
(safsaf)
|
||
|
|
(safsaf handler-wrappers csrf)
|
||
|
|
(safsaf handler-wrappers logging)
|
||
|
|
(safsaf response-helpers)
|
||
|
|
(safsaf router)
|
||
|
|
(safsaf utils)
|
||
|
|
(safsaf params))
|
||
|
|
|
||
|
|
;;;
|
||
|
|
;;; Paste storage (in-memory)
|
||
|
|
;;;
|
||
|
|
|
||
|
|
(define %pastes (make-hash-table))
|
||
|
|
(define %next-id 0)
|
||
|
|
|
||
|
|
(define (store-paste! content)
|
||
|
|
"Store CONTENT and return its integer ID."
|
||
|
|
(let ((id %next-id))
|
||
|
|
(set! %next-id (1+ id))
|
||
|
|
(hashv-set! %pastes id content)
|
||
|
|
id))
|
||
|
|
|
||
|
|
(define (fetch-paste id)
|
||
|
|
"Return the paste content for integer ID, or #f."
|
||
|
|
(hashv-ref %pastes id))
|
||
|
|
|
||
|
|
;;;
|
||
|
|
;;; Handlers
|
||
|
|
;;;
|
||
|
|
|
||
|
|
(define (paste-form-page errors content-val)
|
||
|
|
"Render the paste form, optionally with validation errors and prior input."
|
||
|
|
(html-response
|
||
|
|
`(div
|
||
|
|
(h1 "Paste Bin")
|
||
|
|
(form (@ (method "POST") (action "/pastes"))
|
||
|
|
,(csrf-token-field)
|
||
|
|
,@(map (lambda (err) `(p (@ (style "color: #c33")) ,err))
|
||
|
|
errors)
|
||
|
|
(textarea (@ (name "content") (rows "20") (cols "80"))
|
||
|
|
,content-val)
|
||
|
|
(br)
|
||
|
|
(button (@ (type "submit")) "Create Paste")))))
|
||
|
|
|
||
|
|
(define (index-page request body-port)
|
||
|
|
(paste-form-page '() ""))
|
||
|
|
|
||
|
|
(define (create-paste request body-port)
|
||
|
|
(let* ((form (parse-form-body request body-port))
|
||
|
|
(params (parse-form-params
|
||
|
|
`((content ,as-string #:required))
|
||
|
|
form)))
|
||
|
|
(if (any-invalid-params? params)
|
||
|
|
(paste-form-page
|
||
|
|
(field-errors params 'content)
|
||
|
|
(or (assoc-ref form "content") ""))
|
||
|
|
(let ((id (store-paste! (assq-ref params 'content))))
|
||
|
|
(redirect-response (string-append "/pastes/" (number->string id)))))))
|
||
|
|
|
||
|
|
(define (show-paste request body-port)
|
||
|
|
(let* ((params (current-route-params))
|
||
|
|
(id-str (assoc-ref params 'id))
|
||
|
|
(id (string->number id-str))
|
||
|
|
(content (and id (fetch-paste id))))
|
||
|
|
(if content
|
||
|
|
(html-response
|
||
|
|
`(div
|
||
|
|
(h1 "Paste " ,id-str)
|
||
|
|
(pre ,content)
|
||
|
|
(p (a (@ (href "/")) "New paste"))))
|
||
|
|
(not-found-response "Paste not found"))))
|
||
|
|
|
||
|
|
;;;
|
||
|
|
;;; Logging setup
|
||
|
|
;;;
|
||
|
|
|
||
|
|
(define (setup-logging)
|
||
|
|
(let ((lgr (make <logger>))
|
||
|
|
(handler (make <port-log> #:port (current-error-port))))
|
||
|
|
(add-handler! lgr handler)
|
||
|
|
(set-default-logger! lgr)
|
||
|
|
(open-log! lgr)))
|
||
|
|
|
||
|
|
(setup-logging)
|
||
|
|
|
||
|
|
;;;
|
||
|
|
;;; Routes and entry point
|
||
|
|
;;;
|
||
|
|
|
||
|
|
(define %port 8081)
|
||
|
|
|
||
|
|
(define paste-routes
|
||
|
|
(wrap-routes
|
||
|
|
(list
|
||
|
|
(route 'GET '() index-page)
|
||
|
|
(route 'POST '("pastes") create-paste)
|
||
|
|
(route 'GET '("pastes" id) show-paste)
|
||
|
|
(route '* '* (lambda (request body-port) (not-found-response))))
|
||
|
|
logging-handler-wrapper
|
||
|
|
csrf-handler-wrapper))
|
||
|
|
|
||
|
|
(format #t "Paste Bin listening on port ~a~%" %port)
|
||
|
|
(run-safsaf paste-routes #:port %port)
|