Welcome to the CHICKEN Scheme pasting service
spiffy randomness added by andyjpb on Fri Apr 13 10:46:41 2012
(use awful sxml-transforms doctype)
(use awful-sql-de-lite sql-de-lite)
(use spiffy)
(use regex)
;TODO: Disable the spiffy filesystem handler
; Use SXML transforms to generate the pages.
(define (define-sxml-page path contents)
(define-page path
(lambda args
(with-output-to-string
(lambda ()
(SXML->HTML `(body ,(apply contents args)))
(awful-response-headers '((content-type "text/html")))))) ; content-type persists in a reused thread
doctype: doctype-xhtml-1.0-transitional
css: (++ (main-page-path) "pdam.css")))
;(enable-session #t)
(enable-session-inspector "session-inspector")
(session-inspector-access-control
(lambda ()
#f))
(enable-db)
(db-credentials "photo-assets.sqlite")
(define-login-trampoline "/login-trampoline")
(valid-password?
(lambda (user password)
(equal? user password)))
(define-page (login-page-path)
(lambda ()
(login-form))
no-session: #t)
; Procedures
; Take a piece of text and render it into a series of html lines.
(define (render-text text)
(if (string? text)
(let ((lines (string-split text "\n")))
(append (list (car lines)) (map (lambda (line) `((br) ,line)) (cdr lines))))
#f)
)
; Call the iterator to get an alist. Render the a list according to the headings.
; Produce an SXML table with each alist returned from the iterator rendered as an SXML row.
(define (render-row-as-row iter headings)
; Turn the results of the query into table rows.
(let ((rows '()))
(let loop ((row (iter)))
(if (not (null? row))
(begin
(set! rows (append! rows
`((tr
,(map (lambda (col)
(let ((col_href (alist-ref (string->symbol (++ col "_href")) row))
(col_data (alist-ref (string->symbol col) row)))
(if (string? col_href)
`(td (a (@ href ,(++ (main-page-path) col_href)) ,col_data))
`(td ,(render-text col_data))
)))
headings)))
))
(loop (iter)))))
`(table
; Create table headings for the column names that don't end with "_href".
,(map (lambda (col) `(th ,col)) headings)
; Populate the rows of the table with the rows generated from the query.
,rows
)
))
; Call the iterator to get an alist. Render the a list according to the headings.
; Produce an SXML table with each alist returned from the iterator rendered as a set of SXML rows.
(define (render-row-as-col iter headings)
(let ((rows '())
(imgs '()))
(let loop ((row (iter)))
(if (not (null? row))
(begin
(set! rows (append! rows
(map (lambda (col)
(let ((col_href (alist-ref (string->symbol (++ col "_href")) row))
(col_data (alist-ref (string->symbol col) row)))
`(tr
(th ,col)
,(if (string? col_href)
`(td (a (@ href ,(++ (main-page-path) col_href)) ,col_data))
`(td ,(render-text col_data))
))))
headings)))
(set! imgs (append! imgs (let ((img (alist-ref (string->symbol "_img") row)))
(if img `(img (@ src ,(++ (main-page-path) img))) '()))))
(loop (iter)))))
`(
,imgs
(table
,rows))))
; Call the iterator once. Set the content type and return an appropriately
; stringified blob.
; We can only have one of these per response.
(define (render-row-as-image iter headings)
(let* ((row (iter))
(img (alist-ref (string->symbol "img") row))
(img_mime (alist-ref (string->symbol "img_mime_type") row)))
(awful-response-headers `((content-type ,img_mime)))
(blob->string img)))
(define (render-row-as-image-sender iter headings)
(let* ((row (iter))
(directory (alist-ref (string->symbol "directory") row))
(filename (alist-ref (string->symbol "filename") row))
(img_mime (alist-ref (string->symbol "mime_type") row)))
(awful-response-headers `((content-type ,img_mime)))
(parameterize ((root-path directory))
(send-static-file filename))
))
; Return a procedure that runs a query of the form "SELECT * FROM ;" and tries to render it with the supplied renderer.
(define (create-view-renderer renderer)
(lambda (stmt . args)
(let*
;((stmt (prepare (db-connection) (++ "select * from " table ";")))
((stmt (prepare (db-connection) stmt))
; List of columns whose names don't end with _href
(columns (filter (lambda (col) (and (= 0 (string-prefix-length col "_")) (= 0 (string-suffix-length col "_href"))))
(map symbol->string (column-names stmt))))
(rows '()))
(apply bind-parameters stmt args)
(set! rows (renderer (lambda () (fetch-alist stmt)) columns))
(finalize stmt)
rows
)))
; Run a query of the form "SELECT * FROM ;" and try to render it into an SXML table.
(define render-view (create-view-renderer render-row-as-row))
; Run a query and render each result column as an SXML row.
; This is useful for queries that return a single result.
(define render-row (create-view-renderer render-row-as-col))
; Run a query and render the result as an image.
; Set the awful-response-header content-type.
(define render-image (create-view-renderer render-row-as-image))
; Run a query, find the file mentioned in the results and send it to the browser.
; Set the awful-response-header content-type.
(define send-image (create-view-renderer render-row-as-image-sender))
; Page defintions follow
(define-sxml-page (main-page-path)
(lambda ()
`((h1 "Photo Digital Asset Management v0.1")
(ul
(li (a (@ href "/assets/") "Asset List"))
(li (a (@ href "/tags/") "Tag List"))
))
))
(define-sxml-page "assets"
(lambda ()
`((h1 "Full Asset List")
(p "This report lists all assets in the system.")
,(render-view "select * from v_assets;"))
))
(define-sxml-page (regexp "/assets/[^/]+")
(lambda (path)
(let* ((paths (string-split path "/"))
(asset_id (second paths))
)
`((h1 "Asset " ,asset_id)
,(render-row "select * from v_assets where asset_id=@AI;" asset_id)
(img (@ (src ,(string-append "/files/" asset_id "/THUMBNAIL")) (alt "THUMBNAIL")))
,(render-view "select * from v_images where asset_id=@AI;" asset_id)
)
)))
;(define-page (regexp "/files/[^/]+/[^/]+")
; (lambda (path)
; (let* ((paths (string-split path "/"))
; (asset_id (second paths))
; (type (third paths)))
; (send-image "select * from v_images where asset_id = @asset_id and type = @type;" asset_id type)
; "")) no-template: #t)
Your annotation:
Enter a new annotation: