#lang scheme/base
(require (planet "leftparen.scm" ("vegashacker" "leftparen.plt" 5 (= 1)))
(planet "util.scm" ("vegashacker" "leftparen.plt" 5 (= 1)))
mzlib/defmacro
"app.scm"
"data.ss"
"social.ss"
"discuss.ss"
"templates.ss"
"markup.ss"
"tags.ss"
"admin.ss")
(provide index-page-view
gen-show-list-view
feature-detail-page-view
gen-tag-page
)
;; this might be the ugliest function definition ever created in the
;; history of PLT Scheme
(define (req-link sesh
str
#:post-pool (post-pool #f)
#:tag-list (tags #f))
`(a ((href ,(body-as-url (req)
(post-feature-view sesh
#:post-pool post-pool
#:tag-list tags))))
,str))
(define (slugify xs)
(cond
((null? xs) "")
(else
(string-append (car xs) "-" (slugify (cdr xs))))))
(define (gen-feature-link feat)
(format "/feature/~A~A~A"
(rec-id feat)
"-"
(car (regexp-match
#px".{,90}[[:alnum:]]"
(slugify
(regexp-split #px"[^[:alnum:]]+"
(rec-prop feat 'explanation)))))))
(define (index-page-view sesh)
(page
#:design (base-design)
`(div ((id "docindex"))
(h1 "lawnelephant")
(div ((id "bd"))
(div ((id "elephant-holder"))
(a ((href "/tag/"))
(img ((src "i/elephant.jpg")
(alt "The logo for lawnelephant. It looks like a green elephant."))))))
(div ((id "indexft"))
(div ((class "intro"))
(a ((href "/tag/")) "browse all the posts on lawnelephant"))
(div ((id "tagcloud"))
,@(map (lambda (t)
`(span ,(tag-subst t #:supress-hash #t) " "))
(gen-tag-list (get-feature-requests-generic))))
(ul
,(li-a "http://blog.lawnelephant.com/post/74637624/introducing-lawnelephant-com" "about")
,(li-a "http://blog.lawnelephant.com" "blog")
,(li-a "http://github.com/vegashacker/lawnelephant/tree/master" "source code")
,(li-a "mailto:ask@lawnelephant.com" "ask@lawnelephant.com")
,(li-a "http://twitter.com/lawnelephant" "@lawnelephant"))
;; XXX goog analytics really needs to be just before the closing body tag, but I
;; don't know how to put it there just yet
,(raw-str goog-analytics)))))
(define (post-feature-view sesh
#:post-pool (post-pool #f)
#:tag-list (tags #f)
#:form-view (form-markup request-feature-form-view))
(page
#:design (base-design)
`(div ((id "doc"))
,(xexpr-if (and post-pool tags) (awesomecloud post-pool tags))
(div ((id "bd"))
(div ((id "requests"))
,(form-markup sesh)))
(div ((id "instructions"))
"Make your post easier to find by adding tags. Just put a # before any word to turn it into a tag. For example "
,(web-link "#feature" "/tag/feature")
" or "
,(web-link "#question" "/tag/question"))
(div ((id "indexft"))
(ul
,(li-a "http://blog.lawnelephant.com/post/74637624/introducing-lawnelephant-com" "about")
,(li-a "http://blog.lawnelephant.com" "blog")
,(li-a "http://github.com/vegashacker/lawnelephant/tree/master" "source code")
,(li-a "mailto:ask@lawnelephant.com" "ask@lawnelephant.com")
,(li-a "http://twitter.com/lawnelephant" "@lawnelephant"))
;; XXX goog analytics really needs to be just before the closing body tag, but I
;; don't know how to put it there just yet
,(raw-str goog-analytics)))))
(define (feature-detail-page-view sesh feat-id)
(page
#:design (base-design #:title "permalink at lawnelephant")
`(div ((id "doc"))
(div ((id "hd"))
(a ((href "/"))
(span ((id "text-logo")) "lawnelephant"))
(span ((id "arrow"))
,(raw-str "→"))
(span ((id "singlethread")) "you are looking at a single thread"))
(div ((id "bd"))
(ul ,(feature-req-view sesh feat-id #:reply-redirect (gen-feature-link feat-id))))
,(div-footer))))
(define (gen-tag-page sesh tag)
(let* ((tags (if tag
(regexp-split #px"[^[:alnum:]]" tag)
'()))
(post-pool (if tag
(get-feature-requests-by-tags tags)
(get-feature-requests-generic))))
(page
#:design (base-design #:title (aif tag ; to handle when tag is #f
(format "~A at lawnelephant" it)
"all posts at lawnelephant"))
`(div ((id "doc"))
,(awesomecloud post-pool tags)
,(subhead-div sesh #:post-pool post-pool #:tag-list tags)
(div ((id "bd"))
(ul ,@(map (cut feature-req-view sesh <>) post-pool)))
,(div-footer)))))
(define (hd-div)
`(div ((id "hd"))
(a ((href "/")
(id "text-logo")) "lawnelephant")))
;; note: use delete-duplicates to handle posts like: "#idoh #idoh something ..."
(define (awesomecloud post-pool tag-list)
`(div ((id "awesomecloud"))
(a ((href "/")
(id "text-logo")) "lawnelephant")
(span ((id "arrow"))
,(raw-str "→"))
,@(map (lambda (t) (tag-subst t #:supress-hash #t #:tag-list tag-list))
(delete-duplicates (gen-tag-list post-pool)))))
(define (subhead-div sesh
#:post-pool (post-pool #f)
#:tag-list (tags #f))
`(div ((id "subhead"))
(div ((id "posta"))
,(req-link sesh "post" #:post-pool post-pool #:tag-list tags))
(ul ((class "tab"))
,(li-a "/newest" "new")
,(li-a "/popular" "hot")
,(li-a "/completed" "completed"))))
;; once gen-tag-page gets built out this won't be needed anymore
(define (list-page-view sesh title feat-pool)
(page
#:design (base-design #:title (format "~A | lawnelephant" title))
`(div ((id "doc"))
,(hd-div)
,(subhead-div sesh)
(div ((id "bd"))
(ul ,@(map (cut feature-req-view sesh <>)
(feat-pool))))
,(div-footer))))
;; once gen-tag-page gets built out this won't be needed anymore
(define (gen-show-list-view type-str sesh)
(list-page-view sesh type-str
(cond ((string=? type-str "popular") get-feature-requests-popular)
((string=? type-str "newest") get-feature-requests-newest)
((string=? type-str "completed") get-feature-requests-completed)
(else (e "Unrecognized list type str ~A" type-str)))))
(define (request-feature-form-view sesh)
(form '((explanation "" long-text))
#:submit-label "post"
#:init `((type . feature-request)
(author. ,(session-id sesh)))
#:error-wrapper (lambda (error-form-view)
(index-page-view sesh #:form-view
(lambda (sesh) error-form-view)))
#:validate feature-request-validator
#:on-done (lambda (x) (redirect-to "/newest"))))
(define (make-ago-string str num)
(format "~A ~A ago"
num
(if (eqv? 1 num)
(format "~A" str)
(format "~As" str))))
(define (time-ago created)
(let ((ago (- (current-seconds) created)))
(cond
((> ago 86400)
(make-ago-string "day" (round (/ ago 86400))))
((> ago 3600)
(make-ago-string "hour" (round (/ ago 3600))))
((> ago 60)
(make-ago-string "minute" (round (/ ago 60))))
(else
(make-ago-string "second" ago)))))
(define (feature-req-view sesh feat #:reply-redirect (reply-redirect #f))
`(li (span ((class "explanation"))
,(if (equal? "missing" (feature-request-expl-no-markup feat))
(rec-prop feat 'body)
(feature-request-expl feat)))
;; if the reply is coming from a permalink, then redirect back to the permalink
;; where is the best place to redirect to from elsewhere?
(span ((class "reply"))
,(comment-on-item-link feat sesh #:redirect-to (aif reply-redirect it "/newest")))
,(xexpr-if (rec-type-is? feat 'feature-request)
`(span ((class "features-only"))
,(xexpr-if (in-admin-mode?)
(delete-entry-view feat))
,(xexpr-if (and (not (rec-prop feat 'completed))
(in-admin-mode?))
(mark-as-completed-view feat))
(span ((class "more"))
,(web-link "link" (gen-feature-link feat)))))
,(xexpr-if (can-vote-on? sesh feat)
`(a ((href ,(make-voter-url sesh feat "up"))
(class "up"))
,(raw-str "☆")))
(span ((class "pts")) ,(format "~A" (vote-score feat)))
(span ((class "voteinfo")) "points")
(span ((class "ago")) ,(time-ago (rec-prop feat 'created-at)))
;XXX doesn't look proper, shouldn't I be able to just (when (get-comments feat) ...)
,(xexpr-if (> (count-comments feat) 0)
`(ul ((class "indent")) ,@(map (λ(x) (feature-req-view sesh x #:reply-redirect reply-redirect))
(get-comments feat))))))
(define (delete-entry-view feat-req-rec)
(** " "
(web-link "[delete]" (body-as-url (req) (delete-rec! feat-req-rec)
(redirect-to (page-url index-page))))))
(define (mark-as-completed-view feat-req-rec)
(** " "
(web-link "[mark completed]"
(body-as-url (req)
(rec-set-prop! feat-req-rec 'completed #t)
(store-rec! feat-req-rec)
(redirect-to (page-url index-page))))))
