(import chicken scheme srfi-1 data-structures)
(use srfi-19 irregex anaphora srfi-13 (prefix format format:) numbers crypt
http-session
(only waffle waffle-sxml->html add-widget get-widget widgets widget-rules)
doctype (only sequences intersection difference)
spiffy-cookies
(only uri-common uri-reference uri-encode-string uri-path uri->string)
spiffy intarweb
(prefix format format:) postgresql sql-null matchable
srfi-69 typed-records posix srfi-18 sxml-transforms
sxpath-lolevel html-parser utils simple spiffy-request-vars general-utils
multipart-form-data (except http-client delete-cookie!)
sort-combinators medea
(prefix utf8 utf8:) (prefix utf8-srfi-13 utf8:))
;; (use debug-utils srfi-1 box)
(define *program-config* (with-input-from-file "news.conf" read))
(enable-session #t)
(define (debug a . r)
(log-to (debug-log) (with-output-to-string (lambda () (apply print a r)))))
(define (production?)
(equal? (alist-ref 'server-type *program-config*) 'production))
(let ((expires (string->time "Tue May 21 13:46:22 GMT 2020")))
(cond ((production?)
(session-cookie-setter
(lambda (sid)
(set-cookie! (session-cookie-name) sid
path: (uri-reference "/")
secure: #t http-only: #t
expires: expires))))
((session-cookie-setter
(lambda (sid)
(set-cookie! (session-cookie-name) sid
path: (uri-reference "/")
expires: expires))))
(else (error "unknown server type"))))
(include "db.scm")
(import (prefix news-db db:))
(define with-db db:with-db)
(define with-db/transaction db:with-db/transaction)
(db:connection-spec (alist-ref 'db-connection-spec *program-config*))
(define user-id (make-parameter #f))
(define (define-widget-page path contents #!key css title doctype headers charset
(method 'GET) use-session)
(define-page path
(lambda args
(parameterize ((widgets *widgets*) (widget-rules *widget-rules*))
(apply contents args)))
css: css title: title doctype: doctype method: method
headers: headers
charset: charset))
(include "global.scm")
(include "macros.scm")
(import news-macros)
(define (subscribe-to-mailing-list email)
(let* ((uri
(uri-reference
"https://us11.api.mailchimp.com/3.0/lists/59a8a7b46b/members/"))
(req (make-request
method: 'POST
uri: uri
headers: (headers
'((content-type application/json)
(authorization
#(basic ((username . "foo")
(password . "08707fcc5729fcd8add03466f29eec0a-us11")))))))))
(with-input-from-request
req
(json->string `((email_address . ,email)
(status . "subscribed")))
read-string)))
(define-record article (article-id : number) (title : string) (author : string)
date (content : string) (description : string)
(tags : list) (rank : number) (cover-image-path : string)
(cover-image-width : number) (cover-image-height : number)
(has-cover-image : boolean) (url : string) (points : number)
(source-name : string) (source-icon-path : string) (source-id : number)
(authors : list))
(define *tags* (with-db (lambda (conn) (db:get-tags-by-rank conn))))
(define *categories* `("top-news" ,@*tags*))
(define *sources* '())
(define (refresh-sources!)
(set! *sources* (with-db (lambda (conn) (db:get-sources conn)))))
(refresh-sources!)
(define (source-ids)
(map (cut alist-ref 'source-id <>) *sources*))
(define (source-names)
(map (cut alist-ref 'name <>) *sources*))
(define (default-sources-ids)
(map (cut alist-ref 'source-id <>) *sources*))
(define (default-sources) *sources*)
(define default-possible-sources
(make-parameter
(filter (lambda (s)
(member (alist-ref 'name s)
'("New York Times" "Wall Street Journal" "Los Angeles Times"
"San Francisco Chronicle" "Fox News" "NPR")))
*sources*)))
(define (sources->source-id-list sources)
(map (cut alist-ref 'source-id <>) sources))
(include "widgets")
(define (refresh-articles!)
(with-db/transaction
(lambda (conn)
(db:refresh-article-view! conn))))
(define (add-user conn email #!key password)
(if email
(with-transaction conn
(lambda ()
(let ((id (car
(row-values
(if (not password)
(db:add-user! conn email)
(let ((salt (crypt-gensalt)))
(db:add-user! conn email
hash: (crypt password salt) salt: salt)))))))
id)))
(error "email must be specified")))
(define (account-exists? conn email)
(db:account-exists? conn email))
(define (create-account conn email password)
(if (not (account-exists? conn email))
(with-transaction conn
(lambda ()
(let ((salt (crypt-gensalt)))
(db:create-account!
conn ($session 'user-id) email (crypt password salt) salt))))
(signal db:account-exists-condition)))
(define (valid-password? conn email password)
(and-let* ((db-password-and-salt
(db:get-password-and-salt conn email))
(_ (> (row-count db-password-and-salt) 0)))
(string=? (crypt password (value-at db-password-and-salt 1 0))
(value-at db-password-and-salt 0 0))))
(define (article-upvoted? conn user-id article-id)
(> (row-count
(db:article-upvoted? conn user-id article-id))
0))
(define (signed-in? conn sid) (db:user-signed-in? conn (user-id) sid))
(define (sign-in-user user-id)
($session-set! 'user-id user-id))
(define (user-has-subscriptions conn)
(db:user-has-subscriptions conn (user-id)))
(define (subscriptions conn)
(db:get-user-subscriptions conn (user-id)))
(define (subscribe conn #!key source-id source-name type value value-id)
(cond ((equal? type 'tag)
(db:user-tag-subscribe! conn value (user-id) source-id))
((equal? type 'author)
(db:user-author-subscribe! conn value-id (user-id)))
(else (error (conc "type not supported: " type)))))
(define (unsubscribe conn #!key source-id source-name type value value-id)
(if (equal? type 'tag)
(db:user-tag-unsubscribe! conn value (user-id) source-id)
(db:user-author-unsubscribe! conn value-id (user-id))))
(define (subscribed? conn type #!key value-name value-id source-ids)
(not (null? (filter
(lambda (l)
(or (and (equal? type 'tag)
(equal? (alist-ref 'value-name l) value-name)
(member (alist-ref 'source-id l) source-ids))
(and (equal? type 'author)
(equal? value-id (alist-ref 'value-id l)))))
(subscriptions conn)))))
(define (get-top-bar-items conn user-id)
(append
'(((text . "Top News")
(uri . "/")
(id . "top-news")))
(map (lambda (item)
(let ((string-id (string-intersperse
(string-split (alist-ref 'value item)
" ")
"-")))
(if (eq? (alist-ref 'type item) 'tag)
`((text . ,(string-titlecase
(alist-ref 'value item)))
(uri . ,(++ "/" string-id))
(id . ,string-id))
`((text . ,(alist-ref 'value item))
(uri . ,(uri->string
(uri-reference
(conc "/author/" string-id "/"
(alist-ref 'id item)))))
(id . ,string-id)))))
(db:get-user-headers conn user-id))))
(define (user-sources conn)
(let ((r (db:get-user-sources conn ($session 'user-id))))
(if (null? r)
(default-possible-sources)
r)))
(define (set-user-sources! conn sources)
(db:set-user-sources! conn ($session 'user-id) sources))
(session-storage-initialize
(lambda ()
;; TODO check for table and columns
#t))
(session-storage-set!
(lambda (sid session-item)
(with-transaction (db:db-connection)
(lambda ()
(let ((bindings (session-item-bindings session-item)))
(if (and (not (null? bindings)) (null? (cdr bindings))
(assoc 'user-id bindings))
(db:set-session-user-id! (db:db-connection)
sid (alist-ref 'user-id bindings)
(session-item-expiration session-item))
(abort (conc "Invalid session item set. Only user-id is allowed.\n"
bindings))))))))
(session-storage-session-create!
(lambda (sid session-item)
(with-transaction (db:db-connection)
(lambda ()
(let ((user-id (add-user (db:db-connection) sid)))
(db:set-session-user-id!
(db:db-connection)
sid user-id (session-item-expiration session-item) new-session: #t))))))
(session-storage-session-id-exists
(lambda (sid)
(db:session-exists? (db:db-connection) sid)))
(session-storage-ref
(lambda (sid)
(when (not sid) (abort (conc "session id not specified")))
(let ((r (db:get-session-user-id (db:db-connection) sid)))
(if (and (> (row-count r) 0) (= (length (row-values r)) 2))
;; expiration, ip address, bindings, finalizer
(make-session-item (car (row-values r))
""
`((user-id . ,(cadr (row-values r))))
#f)
(abort (conc "session id not found: " sid))))))
(session-storage-delete!
(lambda (sid)
(with-transaction (db:db-connection)
(lambda ()
(db:session-delete! (db:db-connection) sid)))))
(define (waffle-sxml->string sxml)
(with-output-to-string
(lambda ()
(waffle-sxml->html sxml))))
(define (text->sxml text)
(map (lambda (para)
`(p ,para))
(string-split text "\n" #f)))
;; for use with getting articles from the db and row-fold*
(define (make-article* id title author date description rank content
cover-image-path cover-image-height cover-image-width
tags points url
source-name source-icon-path source-id authors author-ids o)
(cons
(let ((article
(make-article id title author date
(with-input-from-string content
(lambda () (read)))
description (vector->list tags) rank cover-image-path
cover-image-height cover-image-width
(not (sql-null? cover-image-path))
url
points
source-name
(if (string=? source-icon-path "")
""
(++ (uri->string (uri-source-icon))
"/" source-icon-path))
source-id
(if (or (sql-null? authors) (null? authors)
(sql-null? (vector-ref authors 0)))
'()
(map (lambda (author/id)
`((name . ,(car author/id))
(id . ,(cadr author/id))))
(zip (vector->list authors)
(vector->list author-ids)))))))
article) o))
(define (get-article-by-id conn id)
(car
(apply
make-article*
(append (db:get-article-by-id
conn (if (string? id) (string->number id) id))
'(nil)))))
(define (get-articles-by-tags conn tags #!key limit exclude-ids (sort 'date)
(sources (default-sources)))
(reverse
(row-fold*
make-article*
'()
(db:get-articles-by-tags conn tags limit: limit exclude-ids: exclude-ids
sources: (sources->source-id-list sources) sort: sort))))
(define (get-articles-by-popularity conn #!key tags limit offset exclude-ids
(sources (default-sources)))
(reverse
(row-fold*
make-article*
'()
(db:get-articles-by-popularity conn tags: tags exclude-ids: exclude-ids
offset: offset limit: limit
sources: (sources->source-id-list sources)))))
(define (get-users-articles conn user-id limit #!key rank tag)
(reverse
(row-fold* make-article*
'()
(db:get-users-articles
conn user-id limit rank: rank tag: tag))))
(define (get-feed-articles conn type tags #!key exclude-ids
(sources (default-sources-ids)) (limit 6))
(get-articles-by-tags conn tags limit: limit exclude-ids: exclude-ids
sources: sources))
(define (get-articles-by-authors conn authors #!key limit (exclude-ids '()))
(reverse
(row-fold*
make-article*
'()
(db:get-articles-by-authors conn authors limit: limit exclude-ids: exclude-ids))))
(define (get-top-article conn tags #!key exclude-ids (sources (default-sources)))
(car (get-articles-by-tags
conn tags limit: 1 sort: 'rank exclude-ids: exclude-ids sources: sources)))
(define (mark-article-viewed conn id)
(db:mark-article-viewed! conn id ($session 'user-id))
(db:increment-article-viewed! conn id))
(define (articles-viewed-by-user conn user-id)
(db:get-articles-viewed-by-user conn user-id))
(define (user-tags conn user-id)
(column-values (db:user-tags conn user-id)))
(define (user-categories conn)
(append '("top-news") (user-tags conn ($session 'user-id))))
(define (feed-title-by-type type)
(if (eq? type 'popular)
"Most popular"
"Latest news"))
(define (get-image-dimensions path)
(map
string->number
(string-split
(with-input-from-pipe (string-append "identify -format \"%w,%h\" " path) read-string)
",")))
(define (maybe-create-session)
(unless (and (connection? (db:db-connection)) (connected? (db:db-connection)))
(db:db-connection (connect (db:connection-spec))))
(let ((ua (header-value 'user-agent (request-headers (current-request)) '())))
(when (and (not (null? ua)) (>= (length (car ua)) 3)
(or
(equal? (third (car ua))
"http://www.pingdom.com/")
(string-contains (third (car ua)) "bot")))
(sid "4706c04b9436d8bbab979fea126b9375c49ab039")))
(when (not (session-valid? (sid)))
(if (session-valid? (read-cookie (session-cookie-name)))
(sid (read-cookie (session-cookie-name)))
(begin (sid (session-create))
((session-cookie-setter) (sid))
(set-user-sources!
(db:db-connection) (default-possible-sources))
(db:set-new-user-default-interests!
(db:db-connection) ($session 'user-id) 455000)
;; (db:set-user-default-interests!
;; (db:db-connection) ($session 'user-id)
;; "default-common")
)))
(user-id ($session 'user-id)))
(add-request-handler-hook!
'foo
(lambda (path handler)
(unless (and (connection? (db:db-connection)) (connected? (db:db-connection)))
(db:db-connection (connect (db:connection-spec))))
(maybe-create-session)))
(add-post-request-handler-hook!
'foo
(lambda (path handler)
(disconnect (db:db-connection))
(db:db-connection #f)))
(define (get-minutes date)
(/ (time-second (date-difference (current-date) date)) 60))
(get-minutes (make-date 0 0 0 0 1 2 2015))
(define-inline (num->int n)
(inexact->exact (ceiling n)))
(define (time-in-past-natural date)
(let ((minutes (/ (time-second (date-difference (current-date) date)) 60)))
(cond ((< minutes 60) (string-append (number->string (num->int minutes))
" minutes ago"))
((< minutes 1440) ; less than 1 day
(string-append (number->string (num->int (/ minutes 60)))
" hours ago"))
((< minutes 10080) ; less than 1 week
(format:format #f "~D day~:P ago" (num->int (/ minutes 1440))))
((< minutes 43200) ; less than 1 month
(format:format #f "~D week~:P ago" (num->int (/ minutes 10080))))
((< minutes 525600)
(format:format #f "~D month~:P ago" (num->int (/ minutes 43200))))
(else
(format:format #f "~D year~:P ago" (num->int (/ minutes 524160)))))))
(define *pre-generated-html*
(with-input-from-file (filesystem-path-pre-generated-html) (lambda () (read))))
(define *news-javascript-html* (alist-ref 'news-javascript-html *pre-generated-html*))
(define *news-load-javascript* (alist-ref 'news-load-javascript *pre-generated-html*))
(define *ga-tracking-code*
"")
(define *heap-tracking-code*
(if (production?)
" "
" "))
(define *headers*
(with-output-to-string
(lambda ()
(display "")
(waffle-sxml->html
`((meta (@ (http-equiv "Content-Type") (content "text/html; charset=utf-8")))
(meta (@ (name "description")
(content "Up-to-date news aggregated from online newspapers, blogs, and aggregators personalized for you.")))
(literal ,(alist-ref 'news-stylesheet-html *pre-generated-html*))
(meta (@ (name "viewport")
(content "width=device-width, initial-scale=1.0"))))))))
(define (page-type uri)
(let ((path (uri-path uri)))
(cond ((or (equal? (uri-path (uri-site-root)) path)
(equal? '() path))
'top-news)
((and (or (= (length path) 2) (= (length path) 3))
(member (second path) *tags*))
'tag)
;; ((and-let* ((_ (= (length path) 4))
;; (_2 (string=? (second path) "author"))
;; (author-id (string->number (fourth path)))
;; (db-result (db:get-author-name-by-author-id
;; (db:db-connection) author-id))
;; (author-found (> (row-count db-result) 0))
;; (author-name (value-at db-result)))
;; #t) 'author)
(else #f))))
(define (add-attribute sxml attribute-sxml)
(if (not (member 'visible (flatten sxml)))
(if (and (not (null? (cdr sxml))) (list? (cadr sxml)) (not (null? (cadr sxml)))
(eq? (caadr sxml) '@))
`(,(car sxml) (@ (visible #t) ,@(cdadr sxml)) ,@(cddr sxml))
`(,(car sxml) (@ (visible #t)) ,(cdr sxml)))
sxml))
(define (text->seo-friendly-url text)
(uri-encode-string
(irregex-replace/all
"\\s" (irregex-replace/all
"[^ A-Za-z0-9_]" (string-downcase text) "") "-")))
(define (sxml->longest-strings sxml)
(fold (lambda (e o)
(if (or (string? e) (char? e) (symbol? e))
(if (and (not (null? o)) (string? (car o)))
(cons (conc e (car o)) (cdr o))
(cons (->string e) o))
(cons e o)))
'()
(reverse
(flatten
(pre-post-order*
sxml
universal-conversion-rules*)))))
(define (full-widget-rules)
`((*text* . ,(lambda (tag str) str))
(*default* . ,cons)
(*TOP* . ,(lambda (tag str) str))
. ,*widget-rules*))
(define (compile-sxml sxml)
(sxml->longest-strings
(pre-post-order* sxml (full-widget-rules))))
(define (clambda sxml)
(let ((s (compile-sxml sxml)))
(lambda ()
(SRV:send-reply s))))
(define (example-sxml-compilation)
(SRV:send-reply
(compile-sxml
`(div (span "hi" ,(clambda `(nav "foo")))))))
(define (thumbnail-height height width ideal)
(let* ((ideals '((none . 0) (extra-small . 50)
(small . 80) (medium . 120) (large . 200) (extra-large . 320)))
(ideal-num (alist-ref ideal ideals))
(max-levels (map cdr (filter (lambda (p) (and (<= (cdr p) ideal-num)
(>= height (cdr p))))
ideals)))
(actual-max (apply max max-levels))
(ideal-by-num (map (lambda (p) `(,(cdr p) . ,(car p))) ideals)))
(alist-ref actual-max ideal-by-num)))
(widget
'thumbnail
`(let ((actual-size (thumbnail-height height width size)))
`(div (@ (style ,(++ "background: url('/res/img" src "') no-repeat center center;"))
(class (,(string-append "thumbnail "
(cond ((eq? actual-size 'large)
"thumbnail-large")
((eq? actual-size 'extra-large)
"thumbnail-extra-large")
((eq? actual-size 'medium)
"thumbnail-medium")
((eq? actual-size 'small)
"thumbnail-small")
((eq? actual-size 'extra-small)
"thumbnail-extra-small")
(else ""))
(if class (conc " " class) "")))))))
`((src "") (load-by-default #t) (size 'large)
(width #f) (height #f) (class #f)))
(widget
'top-bar-header
``(row (@ (no-padding #t))
(col (@ (small 3))
(span (@ (class ,(conc "fa fa-bars fa-fw fa-2x menu-bars"
(if show-menu "" " hidden")))
(id "menu-bars"))))
(col (@ (small 6))
(a (@ (href ,(uri->string (uri-site-root))))
(center
(img (@ (src ,logo-uri) (height ,logo-height) (width ,logo-width)
(class "logo-normal"))))))
,@(if show-personalize
`((col
(@ (small 3))
(a (@ (href ,(uri->string (update-uri (uri-personalize)
query: `((selected . ,page))))))
(button (@ (class "button secondary button-small right"))
"personalize"))
(div (@ (id "personalize-tooltip"))
(div (@ (class "triangle-up")))
(p
"Click on personalize to add, remove, or change your topics and sources.")
(center
(button (@ (id "close-tooltip") (class "button"))
"OK got it")))))
'())
(col-end))
`((logo-height "44") (logo-width "126") (page "") (show-menu #t) (show-personalize #t)
(logo-uri ,(alist-ref 'news-logo-normal-uri *pre-generated-html*))))
(widget
'menu
``(div (@ (class "menu-container") (id "menu-container"))
(row (@ (no-padding #f))
(col (@ (small 12) (medium 6) (large 3))
(div (@ (class "menu-header")) "Account")
(ul ,@(if signed-in
`((li (a (@ (href ,(uri->string (uri-account-sign-out))))
(span (@ (class "fa fa-sign-out")))
"Sign out")))
`((li (a (@ (href ,(uri->string (uri-account-create))))
(span (@ (class "fa fa-user-plus")))
"Create account"))
(li (a (@ (href ,(uri->string (uri-account-sign-in))))
(span (@ (class "fa fa-sign-in")))
"Sign in"))))
(li (a (@ (href ,(uri->string
(uri-account-user-metrics-opt-out))))
(icon (@ (icon "area-chart")))
"Analytics and tracking"))))
(col-end)))
`((signed-in #f) (unviewed-only #f)))
(widget
'filter-item-standard
``(a (@ (href ,uri)
(class "js-filter-item-link"))
(div (@ (class
,(string-append
"filter-item"
(if (or (string=? id selected))
" filter-item-selected"
"")))
(id ,(string-append "filter-item-" id)))
,@contents))
'((uri "") (selected "") (id "")))
(widget
'filter-item-personalize
`(begin
`(a (@ (href "javascript:void(0);")
(class "js-filter-item-link"))
(div (@ (class
,(string-append
"filter-item"
(if (or (string=? id (string-intersperse
(string-split selected " ") "-")))
" filter-item-selected"
"")
" js-filter-item-link-personalize"))
(id ,(string-append "filter-item-" id))
(data-id ,id))
,@contents)))
'((uri "") (selected "") (id "")))
(widget
'filter-items
``(row (@ (no-padding #t))
(col (@ (small 12))
(div (@ (class "filter-tags-container"))
,@contents))
(col-end))
`())
(widget
'standard-top-bar-items
`(map (lambda (item)
`(filter-item-standard
(@ (uri ,(alist-ref 'uri item))
(selected ,selected)
(id ,(alist-ref 'id item)))
,(string-titlecase
(irregex-replace/all "-" (alist-ref 'text item) " "))))
items)
'((items ()) (selected "")))
(widget
'personalize-top-bar-items
`(map (lambda (item)
`((filter-item-personalize
(@ (uri ,(alist-ref 'uri item))
(selected ,selected)
(id ,(alist-ref 'id item)))
,(if (equal? (alist-ref 'id item) "top-news")
"All Topics"
(string-titlecase
(irregex-replace/all "-" (alist-ref 'text item) " "))))))
items)
'((items ()) (selected "")))
(widget
'top-bar
``(div (@ (id "top-bar-container") (class "top-bar-container"))
(top-bar-header (@ (page ,page) (show-menu ,show-menu)
(show-personalize ,show-personalize)))
(menu (@ (signed-in ,signed-in) (unviewed-only ,show-unread-only)))
,@contents)
`((filterable #t) (signed-in #f) (show-unread-only #f) (page "")
(show-menu #t) (show-personalize #t)))
(widget
'all-news-personalize-section
`(let ((subscribed-ids (map (lambda (i) (alist-ref 'source-id i)) subscriptions)))
`(row
(col (@ (small 12) (large 6) (large-offset 3))
(column-title "Enable or disable sources across all topics")
,@(map
(lambda (source)
`(row
(col
(@ (small 12))
(follow-button
(@ (show-names #t) (name ,(alist-ref 'name source))
(source-id ,(alist-ref 'source-id source))
(icon-path ,(alist-ref 'icon-path source))
(value "")
(type "source")
(add ,(not
(member (alist-ref 'source-id source) subscribed-ids)))))
)))
possible-user-sources))))
'((subscriptions ()) (possible-user-sources ())))
(widget
'personalize-topic-section
``(row
(col (@ (small 12) (large 6) (large-offset 3))
(center (a
(@ (href "javascript:void(0);")
(data-value ,(alist-ref 'tag-name (car sources)))
(data-state "remove")
(data-type "topic")
(class "remove-topic"))
(icon (@ (icon "remove") (class "topic-icon-remove")))
(icon (@ (icon "undo") (class "topic-icon-add display-none")))
" " (span (@ (class "topic-remove-text"))
"Unsubscribe from "
,(string-titlecase
(irregex-replace/all
"-" (alist-ref 'tag-name (car sources)) " ")))))
(column-title "Select sources")
,@(let ((source-ids (map (lambda (sub) (alist-ref 'source-id sub)) subscriptions)))
(map
(lambda (source)
`(row
(col
(@ (small 12))
(follow-button
(@ (show-names #t) (name ,(alist-ref 'source-name source))
(source-id ,(alist-ref 'source-id source))
(icon-path ,(alist-ref 'source-icon-path source))
(add ,(not (member (alist-ref 'source-id source) source-ids)))
(value ,(alist-ref 'tag-name source))))
)))
sources))))
'((sources ()) (subscriptions ())))
(widget
'personalize-section-remove-item
``(center (a
(@ (href "javascript:void(0);")
(data-value ,value)
(data-state "remove")
(data-id ,id)
(data-type ,type)
(class "remove-topic"))
(icon (@ (icon "remove") (class "topic-icon-remove")))
(icon (@ (icon "undo") (class "topic-icon-add display-none")))
" "
(span (@ (class "topic-remove-text")) "Unsubscribe from "
,(string-titlecase
(irregex-replace/all "-" text " ")))))
'((value "") (type "") (text "") (id "")))
(widget
'personalize-author-section
``(row
(col (@ (small 12) (large 6) (large-offset 3))
(personalize-section-remove-item
(@ (type "author") (value ,name) (text ,name) (id ,id)))))
'((name "") (id "")))
(widget
'select-interests-items
``(ul
(@ (class "extra-interests-container"))
,@(let ((items*
(map-in-order
(lambda (item)
(let ((id (conc "selection-checkbox-" (random 10000000))))
`(div (@ (class ,(++ "selection-checkbox-container "
"interest-element-container"
(if show "" " display-none")))
(data-name ,(alist-ref text-key item)))
(input (@ (type "checkbox")
(class "selection-checkbox interest-item-input")
(id ,id)
(data-type ,type)
(data-valueid ,(alist-ref id-key item))
(data-value ,(alist-ref text-key item))
,@(if source-key
`((data-sourceid
,(alist-ref source-key item)))
'())
,@(if (member (alist-ref text-key item) selected)
`((checked))
'())))
(label
(@ (for ,id))
(div
(@ (class "selection-label-container"))
,(string-titlecase
(irregex-replace/all "-" (alist-ref text-key item) " ")))))))
(sort
items
(lambda (i1 i2)
(if (assoc 'tag-rank i1)
(< (alist-ref 'tag-rank i1)
(alist-ref 'tag-rank i2))
(string< (alist-ref 'author-name i1)
(alist-ref 'author-name i2))))))))
`(,@(if (not (null? items*))
`((li (@ (id "interest-element-header-topics"))
(strong ,title)))
'())
,@items*)))
'((items ()) (text-key nil) (id-key nil) (source-key #f) (title "") (selected ())
(type "") (show #t)))
(widget
'select-interests
``(div (@ (class "select-interests-container") (id "select-interests-container"))
(row
(@ (no-padding #t) (id "default-topics-container"))
,@(map
(lambda (e)
`(col
(@ (small 6) (large 4))
(div
(@ (class "interest-image-container")
(data-type "topic")
(data-valudid ,(alist-ref 'tag-id e))
(data-value ,(alist-ref 'tag-name e)))
(div (@ (class "interest-image-overlay")))
(img (@ (src ,(++ (uri->string (uri-img-icon)) "/"
(alist-ref 'tag-name e) "-square.jpg"))))
(div (@ (class "interest-image-checkmark-container"))
(icon (@ (icon "check-circle") (class "display-none")))
(icon (@ (icon "plus-circle"))))
(div (@ (class "interest-image-text"))
(center ,(alist-ref 'tag-name e))))))
common)
(col (@ (small 12))
(hr)))
(select-interests-items (@ (items ,tags) (text-key tag-name)
(title "Topics") (selected ,tags-selected)
(type "topic") (source-key source-id)
(id-key tag-id)))
(div (@ (id "author-interests-container"))))
'((common ()) (tags ()) (tags-selected ())))
(widget
'article-card-info-row
``(row (@ (no-padding #t))
(col (@ (no-padding #t) (small 6))
,@(if show-upvote
`((span
(@ (class ,(string-append
"fa fa-lg fa-thumbs-up upvote "
"article-" (number->string id) "-upvote"))
(data-article-id ,id))))
'())
,@(if points
;; An article's points are cached. If the user has
;; upvoted an article they expect the point value
;; to increase. But if the article's point value
;; hasn't been updated since then it will not
;; appear that their upvote worked. So we fake it
;; by adding a point if they have upvoted the
;; article. Technically it can give an inflated
;; number but shouldn't matter.
`((span
(@ (class
,(string-append
"article-" (number->string id)
"-points"))) ,(if show-upvote points (+ points 1)))
,(format:format #f " point~P" (if show-upvote points (+ points 1))))
'()))
(col (@ (small 6))
(span (@ (style "color: #aaa;")
(class "right"))
,(time-in-past-natural date))))
`((show-upvote #f) (id 'nil) (points 5) (date date)))
(widget
'article-card-author-list
`(fold (lambda (author o)
`((a (@ (href ,(++ (uri->string (uri-author)) "/"
(text->seo-friendly-url (alist-ref 'name author))
"/" (number->string (alist-ref 'id author))))
(data-viewed-ignore "true"))
,(alist-ref 'name author))
,@(if (null? o) '() '(" and "))
,@o
))
'()
authors)
'((authors ())))
(widget
'article-source-line
``(p (@ (class "tiny-font source-line"))
,@(if (string=? (article-source-icon-path article) "")
'()
`((img (@ (src
,(article-source-icon-path article))
(width "16px") (height "16px")))))
(span ,(article-source-name article)))
'((article #f)))
(widget
'article-image-title-row
``(div
(@ (class "flex-container flex-align-center"))
(a
(@ (href ,(article-url article)) (class "unstyled-link"))
,(if (article-has-cover-image article)
`(thumbnail
(@ (src ,(string-append
"/original/" (article-cover-image-path article)))
(style "display: block; margin: 0 auto;")
(load-by-default #f)
(height ,(article-cover-image-height article))
(width ,(article-cover-image-width article))
(size large)))
`(thumbnail
(@ (src "/icons/image-filler.svg")
(style "display: block; margin: 0 auto;")
(height 100)
(width 100)
(size large)
(class "filler-image")))))
(a (@ (href ,(article-url article)) (class "unstyled-link"))
(,header-size
(@ (class "headline")) ,(article-title article))))
'((article #f) (header-size h3)))
(widget
'article-card
`(let* ((_type-properties
'((featured . ((header-size . h2) (show-img . #t) (font-class . "")
(thumbnail-size . extra-large) (show-details . #t)
(show-img-small . #t) (show-img-medium . #t)
(description-length . 500)))
(large . ((header-size . h3) (show-img-medium . #t) (font-class . "")
(thumbnail-size . medium) (show-details . #t)
(show-img-small . #t)
(description-length . 300)))
(normal . ((header-size . h5) (show-img-medium . #t) (font-class . "")
(thumbnail-size . medium) (show-details . #t)
(show-img-small . #t)
(description-length . 100)))
(small . ((header-size . h6) (show-img-medium . #t) (show-img-small . #t)
(font-class . "") (thumbnail-size . small) (show-details . #f)))
(tiny . ((header-size . h6) (show-img-medium . #f) (show-img-small . #f)
(font-class . "small-font") (show-details . #f)))))
(type-properties (alist-ref card-type _type-properties))
(default-description-length 100))
(define (truncate-description d len)
(++ (utf8:string-take d (min (utf8:string-length d) len)) "..."))
`(row (@ (no-padding #t))
(div (@ (class ,(string-append
"column small-12 js-article-card article-card"
(if (article-has-cover-image article)
" article-card-with-image"
" article-card-without-image")
(if viewed " article-card-viewed" "")
(if (eq? card-type 'featured) " article-card-featured" "")))
(data-article-id ,(article-article-id article))
(data-article-path ,(article-url article))
(id ,(string-append "article-card-" (number->string
(article-article-id article)))))
(row
(@ (no-padding #t))
(col
(@ (small 12))
(row
(@ (no-padding #t))
(col (@ (small 12))
(article-image-title-row
(@ (article ,article)
(header-size ,(alist-ref 'header-size type-properties))))))
(row
(@ (no-padding #t))
(col
(@ (small 12))
,@(if (alist-ref 'show-details type-properties)
`((p (@ (class "tiny-font byline"))
(article-card-author-list
(@ (authors ,(article-authors article))))
,(if (or (null? (article-authors article))
(string=?
(alist-ref 'name (car (article-authors article)))
""))
""
" :: ")
,(time-in-past-natural (article-date article)))
,(if (and (article-description article)
(not (string=?
(article-description article)
"")))
`(a
(@ (href ,(article-url article))
(class "unstyled-link"))
(p (@ (class "small-font overflow-hidden"))
,(truncate-description
(article-description article)
(or
(alist-ref 'description-length
type-properties)
default-description-length))))
""))
'())))
(article-source-line (@ (article ,article))))))))
`((viewed #f) (display-tags ()) (card-type normal) (points #f) (show-upvote #f)
(category "none") (article 'nil) (show-source #t)))
(widget
'column-title
``(row (@ (no-padding #t))
(col (@ ,@col-size)
,(if (equal? contents '(""))
`(div (@ (class "empty-column-title")))
(if link-uri
`(a (@ (href ,(uri->string link-uri)))
(h5 (@ (class "column-title")) ,@contents))
`(h5 (@ (class "column-title")) ,@contents)))))
`((col-size ((small 12))) (link-uri #f)))
(widget
'feed
`(if (null? articles)
'()
`(div (@ (id ,(++ "feed-container-" (or category "")))
(style ,(if style style ""))
(class ,class))
(row (@ (no-padding #t)) (col (@ (small 12))
(column-title
(@ (link-uri
,(if link-uri link-uri #f)))
,title)))
,@(map (lambda (article)
`(article-card (@ (article ,article)
(viewed ,(member (article-article-id article)
viewed-articles))
(points ,(article-points article))
(card-type ,(if (and card-type-for-first _first-card)
(begin (set! _first-card #f)
card-type-for-first)
card-type))
(category ,(or category ""))
(show-upvote ,(not
(member (article-article-id article)
upvoted-articles)))
(show-source ,(not
(or (null? sources)
(and (not (null? sources))
(null? (cdr sources))))))
(display-tags
,(filter (lambda (t)
(not (string=? t category)))
(article-tags article))))))
articles)))
`((category "") (style #f) (title "") (articles ())
(card-type normal) (card-type-for-first #f) (_first-card #t)
(style #f) (class ()) (upvoted-articles ()) (viewed-articles ())
(link-uri #f) (sources ())))
(widget
'follow-button
``(label
(@ (class "add-follow-label"))
(input (@ (class "follow-icon-container add-follow")
(type "checkbox")
(data-type ,type) (data-value ,value)
(data-value-id #f)
(data-source-id ,source-id)
(data-source-name ,name)
(data-state ,(if add "add" "remove"))
,@(if add '() '((checked)))))
(img (@ (src ,(++ (uri->string (uri-source-icon)) "/" icon-path))
(width "18px") (height "18px")))
" "
,name)
'((add #t) (type "tag") (value "")
(source-id "") (name "") (icon-path "")))
(widget
'subscribe-to-tag-body
``(span
(div (@ (class "follow-icons-outer-container"))
,@(map
(lambda (s)
`(follow-button
(@ (items ,s) (value ,tag)
(add
,(null?
(filter (lambda (f)
(and (equal? (alist-ref 'type f) 'tag)
(equal? (alist-ref 'source-id s) (alist-ref 'source-id f))
(string=? (alist-ref 'value f) tag)))
subscriptions))))))
sources)))
'((category "") (sources ()) (subscribed-to-ids ()) (tag "") (subscriptions ())))
(widget
'subscribe-to-author-body
``(span
(div (@ (class "follow-icons-outer-container"))
(button (@ (class "button follow-icon-container add-follow")
(data-type "author") (data-value ,name)
(data-value-id ,author-id)
(data-state ,(if add "add" "remove")))
(span (@ (class ,(++ "follow-icon-add " (if add "" "display-none"))))
(icon (@ (icon "plus"))))
(span (@ (class ,(++ "follow-icon-remove " (if add "display-none" ""))))
(icon (@ (icon "check-square"))))
" " ,name)))
'((name "") (subscriptions ()) (add #t) (author-id -1)))
(widget
'select-items
``(span
(div (@ (class "checkbox-icons-outer-container"))
,@(map
(lambda (s)
(let ((id (conc "selection-checkbox-" (random 10000000))))
`(div (@ (class "selection-checkbox-container"))
(input (@ (type "checkbox") (class "selection-checkbox")
(id ,id) (name ,input-name)
(value ,(alist-ref 'value s))
,@(if (and (assoc 'checked s)
(alist-ref 'checked s))
`((checked))
'())))
(label
(@ (for ,id))
(div
(@ (class "selection-label-container"))
,@(if (assoc 'icon-path s)
`((img (@ (src ,(++ (uri->string (uri-source-icon)) "/"
(alist-ref 'icon-path s)))
(width "18px") (height "18px"))))
'())
" "
,(alist-ref 'text s))))))
item-map)))
;; item-map looks like ->
;; (((text . "NY Times") (value . "1") (icon-path . "/foo")
;; ((text . "LA Times") (value . "6")))
;; icon-path is optional
'((item-map ()) (input-name "")))
(widget
'flow-button
``(button (@ (type "submit") (class "flow-button"))
,@contents " " (icon (@ (icon "arrow-right"))))
'())
(widget
'subscribe-to-button
``(column-layout
(div
(@ (class "center"))
,@contents))
'())
(widget
'lightbox
``(div (@ (class ,(++ "lightbox-body-container" )))
(div (@ (class ,(++ "lightbox-body" (if full-width " lightbox-full-width" "")))
,@(if id `((id ,id)) '()))
(div (@ (class "right close-lightbox"))
(icon (@ (icon "close") (class "fa-2x"))))
(spacer)
,@contents))
'((id #f) (full-width #f)))
(widget
'main-page
``(div
(@ (id "main-page-outer-container"))
(row (@ (id "main-page-container"))
(col (@ (small 12) (medium 8))
(row
(@ (no-padding #t))
(col
(@ (small 12))
(feed (@ (class "sub-feed-container")
(upvoted-articles ,upvoted-articles)
(title "Top News")
(viewed-articles ,viewed-articles)
(articles ,top-articles)
(sources ,sources)
(card-type normal)
(card-type-for-first normal))))))
(col (@ (id "feed-parent-container") (small 12) (medium 4) (large 4)
(class ""))
(feed (@ (category ,category)
(title ,(++ (feed-title-by-type type)
(if (and category (member category *tags*))
" >" "")))
(upvoted-articles ,upvoted-articles)
(viewed-articles ,viewed-articles)
(articles ,articles)
(sources ,sources)
(link-uri ,(if (and category (member category *tags*))
(let ((uri (uri-reference (++ "/" category))))
(update-uri
uri
path: `(,@(uri-path uri) "latest")))
#f)))))
(col-end)))
`((tags ("")) (type tag) (top-articles #f) (category #f)
(articles ()) (upvoted-articles ()) (viewed-articles ())
(sources ()) (subscribed-to-ids ()) (subscriptable #t)
(subscriptions ())))
(widget
'feed-section
``(col (@ (id "feed-parent-container") (small 12) (medium 10) (large 8)
(medium-offset 1) (large-offset 2)
(class ""))
(feed (@ (category ,(if category category ""))
(title ,title)
(upvoted-articles ,upvoted-articles)
(viewed-articles ,viewed-articles)
(articles ,articles)
(card-type ,card-type))))
'((category "") (title "") (upvoted-articles ())
(viewed-articles ()) (articles ()) (card-type normal)))
(widget
'latest-page
``(div
(@ (id "main-page-outer-container"))
(row (@ (id "main-page-container"))
(feed-section
(@ (type ,type) (category ,category) (title ,title)
(articles ,articles) (upvoted-articles ,upvoted-articles)
(viewed-articles ,viewed-articles) (card-type featured)))
(col-end)))
`((type tag) (category "") (title "")
(articles ()) (upvoted-articles ()) (viewed-articles ())))
(widget
'author-page
``(div
(@ (id "main-page-outer-container"))
;; (subscribe-to-button
;; (subscribe-to-author-body
;; (@ (subscriptions ,subscriptions)
;; (name ,author)
;; (author-id ,author-id)
;; (add
;; ,(null?
;; (filter (lambda (f)
;; (and (equal? (alist-ref 'type f) 'author)
;; (string=? (alist-ref 'value f) author)))
;; subscriptions))))))
(row (@ (id "main-page-container"))
(feed-section
(@ (category ,category) (title ,title)
(articles ,articles) (upvoted-articles ,upvoted-articles)
(viewed-articles ,viewed-articles)
(card-type featured)))
(col-end)))
`((category #f) (title "") (author "") (subscriptions ()) (author-id -1)
(articles ()) (upvoted-articles ()) (viewed-articles ())))
(widget
'select-sources
``(span
(div (@ (class "interest-icons-outer-container"))
,@(map
(lambda (s)
`(follow-button
(@ (s ,s) (show-names #t)
(add
,(null?
(filter (lambda (f)
(and (equal? (alist-ref 'type f) 'tag)
(equal? (alist-ref 'source-id s) (alist-ref 'source-id f))
(string=? (alist-ref 'value f) tag)))
subscriptions)))
)))
sources)))
'((sources ()) (subscriptions ())))
(widget
'accordion-container
``(ul (@ (class "accordion-container"))
,@contents)
'())
(widget
'accordion
``(li
(@ (class "accordion"))
(h5 (@ (class "accordion-header"))
(icon (@ (icon "caret-square-o-right")
(class ,(conc "accordion-closed-icon "
(if open "display-none" "")))))
(icon (@ (icon "caret-square-o-down")
(class ,(conc "accordion-open-icon "
(if open "" "display-none")))))
,(++ " " title))
(row (@ (no-padding #t)
(class ,(conc "accordion-body "
(if open "" "accordion-body-hidden display-none"))))
(col (@ (small 12))
,@contents)))
'((title "") (open #f)))
(widget
'app
``(row (@ (no-padding #t))
(col (@ (small 12)) ,@contents))
`())
(widget
'top-fixed-container
``(div (@ (class "top-fixed-container") (id "top-fixed-container")
(style ,(if visible "" "display: none;")))
(app ,@contents))
`((visible #t)))
(widget
'code/highlight
``(pre (code (@ (class ,lang)) ,@contents))
'((lang "")))
(define *email-sign-up+lightbox*
(with-output-to-string
(lambda ()
(parameterize ((widgets *widgets*) (widget-rules *widget-rules*))
(waffle-sxml->html
`((div (@ (class "lightbox display-none")))
(lightbox
(@ (id "email-signup-container"))
(h4 "Want breaking news updates just for you?")
(p "Subscribe to receive custom breaking news updates and kabonky product updates.")
(p (input (@ (type "email") (placeholder "email address")
(id "subscribe-to-mailing-list-email-address"))))
(p (label (input (@ (type "checkbox") (checked)
(id "subscribe-breaking-news")))
" breaking news updates")
(br)
(label (input (@ (type "checkbox") (checked)
(id "subscribe-product-updates")))
" product updates"))
(p
(button (@ (id "submit-email-sign-up") (class "button"))
"subscribe")))))))))
(define *page-footer*
(with-output-to-string
(lambda ()
(parameterize ((widgets *widgets*) (widget-rules *widget-rules*))
(waffle-sxml->html
`(row
(col (@ (small 12))
(hr)
(center
"contact us at: "
(a (@ (href "mailto:t@thintz.com"))
"t@thintz.com")))
(col (@ (small 12))
(center
"powered by "
(a (@ (href "http://www.call-cc.org/"))
"chicken scheme"))))))
(display "")
(display *news-javascript-html*)
(display ""))))
(define (defpage path thunk #!key title header)
(define-widget-page path
(lambda args
(begin
(replace-header-contents! 'cache-control
'(#(no-cache ()))
(response-headers (current-response)))
(display *headers*)
(display (++ ""
(if title (title) "kabonky")
""))
(when header (header))
(display "")
(display *email-sign-up+lightbox*)
(with-db
(lambda (conn)
(waffle-sxml->html
(apply thunk (cons conn args)))
(if (equal? (alist-ref 'tracking (db:get-user-settings conn (user-id))) #t)
(begin (display *ga-tracking-code*)
(display *heap-tracking-code*))
"")))
(display *page-footer*)))
no-session: #t))
;; TODO bug: overrides the latest page so if it gets redefined after
;; the server is running it will end up earlier in the path matching
;; list and be used for the latest page.
(define (main-page+type/args uri)
(maybe-create-session)
(let* ((type (page-type uri))
(parts (uri-path uri)))
(cond ((equal? type 'top-news)
`(all ,(user-tags (db:db-connection) ($session 'user-id))))
((equal? type 'tag)
`(tag (,(second parts))))
(else #f))))
;; HANDLER: main pages like "top news" or any categories.
(defpage main-page+type/args
(lambda (conn type tags)
(let* ((category (cond ((eq? type 'tag)
(car tags))
((eq? type 'all)
"top-news")
(else (error (++ "type not found: " (->string type))))))
(user-id ($session 'user-id))
(subscriptions (subscriptions conn))
(all-sources (user-sources conn))
(possible-sources (if (equal? type 'all)
all-sources
(db:get-possible-user-sources-for-tag
conn user-id category)))
(tag-sources (if (equal? type 'all)
all-sources
(db:get-user-sources-for-tag conn user-id category)))
(subscribed-ids
(map (cut alist-ref 'source-id <>)
(filter (lambda (s) (equal? (alist-ref 'type s) 'tag)) subscriptions)))
(signed-in (signed-in? conn (sid))))
(let* ((feed-articles (if (equal? type 'all)
(get-users-articles
conn user-id 20 rank: #f)
(get-feed-articles conn type tags
sources: tag-sources)))
(top-articles (get-users-articles conn user-id 30 rank: #t
tag: (if (eq? type 'tag) category #f))))
`(div
(top-fixed-container
(top-bar (@ (signed-in ,signed-in)
(show-unread-only #f)
(page ,category))
(filter-items
(standard-top-bar-items
(@ (items ,(get-top-bar-items conn user-id))
(selected ,category))))))
(app (@ (type ,type))
(div (@ (id "main-page-article-container")))
(main-page
(@ (tags ,tags) (type ,type)
(upvoted-articles ,(db:get-upvoted-articles conn user-id))
(subscribed-to-ids ,subscribed-ids)
(subscriptable ,(not (eq? type 'all)))
(category ,category)
(articles ,feed-articles)
(sources ,possible-sources)
(subscriptions ,subscriptions)
(top-articles ,top-articles)))))))))
;; latest page
(defpage
(lambda (uri)
(let* ((type (page-type uri))
(parts (uri-path uri)))
(if (and (= (length parts) 3) (string=? (third parts) "latest"))
(cond ((equal? type 'top-news)
(maybe-create-session)
`(all ,*tags*))
((equal? type 'popular)
(maybe-create-session)
`(popular ,*tags*))
((equal? type 'tag)
(maybe-create-session)
`(tag (,(second parts))))
(else #f))
#f)))
(lambda (conn type tags)
(let* ((category (cond ((eq? type 'tag)
(car tags))
((eq? type 'popular)
"popular")
((eq? type 'all)
"top-news")
((eq? type 'subscriptions)
"subscriptions")
(else (error (++ "type not found: " (->string type))))))
(user-id ($session 'user-id))
(subscriptions (if (eq? type 'subscriptions) tags (subscriptions conn)))
(signed-in (signed-in? conn (sid))))
(let* ((feed-articles (get-feed-articles
conn type tags
sources: (db:get-user-sources-for-tag
conn user-id category)
limit: 35)))
`(div
(top-fixed-container
(top-bar (@ (signed-in ,signed-in)
(show-unread-only #f)
(page ,category))
(filter-items
(standard-top-bar-items
(@ (items ,(get-top-bar-items conn user-id))
(selected ,category))))))
(app (@ (type ,type))
(div (@ (id "main-page-article-container")))
(latest-page
(@ (tags ,tags) (type ,type)
(upvoted-articles ,(db:get-upvoted-articles conn user-id))
(title ,(feed-title-by-type type))
(category ,category)
(articles ,feed-articles)))))))))
;; author page
;; /author/[author-name]/author-id
(defpage
(lambda (uri)
(let* ((parts (uri-path uri)))
(maybe-create-session)
(and-let* ((_ (= (length parts) 4))
(_2 (string=? (second parts) "author"))
(author-id (string->number (fourth parts)))
(db-result (db:get-author-name-by-author-id
(db:db-connection) author-id))
(author-found (> (row-count db-result) 0))
(author-name (value-at db-result)))
`(,author-id ,author-name))))
(lambda (conn author-id author-name)
(let* ((user-id ($session 'user-id #f))
(signed-in (signed-in? conn (sid))))
(let* ((feed-articles (get-articles-by-authors
conn `(,author-name)
limit: 25)))
`(div
(top-fixed-container
(top-bar (@ (signed-in ,signed-in)
(show-unread-only #f)
(page ,author-name))
(filter-items
(standard-top-bar-items
(@ (items ,(get-top-bar-items conn user-id))
(selected ,(string-intersperse
(string-split author-name " ")
"-")))))))
(app
(div (@ (id "main-page-article-container")))
(author-page
(@ (upvoted-articles ,(db:get-upvoted-articles conn user-id))
(author ,author-name)
(author-id ,author-id)
(subscriptions ,(subscriptions conn))
(title ,author-name)
(viewed-articles '())
(articles ,feed-articles)))))))))
;; personalize page
(defpage (uri-personalize)
(lambda (conn)
(use sort-combinators)
(let* ((subscriptions (subscriptions conn))
(tag-subscriptions
(filter (lambda (s) (equal? (alist-ref 'type s) 'tag))
subscriptions))
(author-subscriptions
(filter (lambda (s) (equal? (alist-ref 'type s) 'author))
subscriptions))
(all-tag-objs (db:get-tags-and-sources conn))
(subscription-ids (map (lambda (s) (alist-ref 'value-id s))
tag-subscriptions))
(tag-objs (filter (lambda (obj) (member (alist-ref 'tag-id obj)
subscription-ids))
all-tag-objs))
(possible-user-sources (db:get-possible-user-sources conn (user-id)))
(selected-page (let ((s ($ 'selected "")))
(if (equal? s "")
"top-news"
s))))
`(div
(top-fixed-container
(row
(col (@ (small 12) (large 6) (large-offset 3))
(spacer (@ (placement horizontal)))
(center (a (@ (href
,(uri->string
(or (let ((r (header-value
'referer
(request-headers (current-request)))))
(if r
(if (equal?
(uri->string
(make-uri path: (uri-path r)))
(uri->string (uri-personalize)))
#f
r)
#f))
(uri-site-root)))))
(button (@ (id "save-and-exit-personalize")
(class "level-3 button")) "Save and exit"))
(button (@ (id "finish-personalize")
(class "display-none level-3 button"))
"Close"))))
(row
(col (@ (small 12) (large 6) (large-offset 3))
(spacer (@ (placement horizontal)))
(input (@ (type "text")
(placeholder "Add topic, author, source")
(id "add-interest-input")))
(select-interests
(@ (common ,(db:get-tags-by-tag-group
conn "common" exclude-user-id: (user-id)))
(tags
,(sort
(map
(lambda (t-lis)
(car t-lis))
(group/key
(lambda (t) (alist-ref 'tag-id t))
(sort all-tag-objs
(lambda (t1 t2)
(< (alist-ref 'tag-id t1)
(alist-ref 'tag-id t2))))))
(lambda (t1 t2) (string< (alist-ref 'tag-name t1)
(alist-ref 'tag-name t2)))))
(tags-selected ,(map
(lambda (sub)
(alist-ref 'value sub))
tag-subscriptions))))))
(row
(@ (no-padding #t))
(col (@ (small 12))
(filter-items
(personalize-top-bar-items
(@ (items ,(get-top-bar-items conn (user-id)))
(selected ,selected-page)))))))
(app
(div
(@ (id "js-personalize-section-all-news")
(class ,(conc
(if (equal? selected-page "top-news")
"" "display-none ")
"js-personalize-section")))
(all-news-personalize-section
(@ (subscriptions
,(map
(lambda (e)
(car e))
(group/key
(lambda (e) (alist-ref 'source-id e))
(sort
tag-subscriptions
(lambda (e1 e2)
(< (alist-ref 'source-id e1)
(alist-ref 'source-id e2)))))))
(possible-user-sources
,(filter (lambda (e) (not (equal? (alist-ref 'name e) "Christianity Today")))
possible-user-sources)))))
,@(map
(lambda (tag-obj)
`(div
(@ (id ,(conc "js-personalize-section-"
(alist-ref 'tag-name (car tag-obj))))
(class ,(conc
(if (equal? (alist-ref 'tag-name (car tag-obj))
selected-page)
"" "display-none ")
"js-personalize-section")))
(personalize-topic-section
(@ (sources ,tag-obj)
(subscriptions
,(filter
(lambda (subscription)
(equal? (alist-ref 'value subscription)
(alist-ref 'tag-name (car tag-obj))))
tag-subscriptions))))))
(group/key
(lambda (obj) (alist-ref 'tag-id obj))
(sort
tag-objs
(lambda (obj1 obj2) (< (alist-ref 'tag-id obj1) (alist-ref 'tag-id obj2))))))
,@(map
(lambda (author)
`(div
(@ (id ,(conc "js-personalize-section-"
(string-intersperse
(string-split (alist-ref 'value author) " ") "-")))
(class ,(conc
(if (equal? (alist-ref 'value author)
selected-page)
"" "display-none ")
"js-personalize-section")))
(personalize-author-section
(@ (name ,(alist-ref 'value author))
(id ,(alist-ref 'value-id author))))))
author-subscriptions))))))
(defpage (uri-account-user-metrics-opt-out)
(lambda (conn)
(let ((signed-in (signed-in? conn (sid))))
`(div
(top-fixed-container
(top-bar (@ (signed-in ,signed-in)
(show-unread-only #f)
(page ""))))
(app
(div (@ (id "main-page-article-container")))
(row
(col (@ (large 6) (large-offset 3) (small 12))
(h3 "You have a right to privacy")
(p "We depend on analytics and tracking software to build this service for you. Without any form of analytics and tracking software it would be much more difficult for us to continue building this product in a way that best fits your needs. But we understand not everyone is comfortable with this software and we believe people have the right to privacy.")
(p "If you are comfortable with this please consider allowing us to continue gathering information so that we can better serve you. Otherwise you may opt-out below and we will not track you.")
(form (@ (action ,(uri->string
(uri-account-user-metrics-opt-out-trampoline))))
(button (@ (class "button") (type "submit"))
,(if (equal? (alist-ref 'tracking (db:get-user-settings conn (user-id))) #t)
"Opt out"
"Opt in"))))
(col-end))))))
title: (lambda () "Tracking and analytics - kabonky"))
(define-page (uri-account-user-metrics-opt-out-trampoline)
(lambda ()
(with-db/transaction
(lambda (conn)
(db:set-user-setting!
conn (user-id) 'tracking
(not (alist-ref 'tracking (db:get-user-settings conn (user-id)))))))
(redirect-to (uri-site-root))))
(define-widget-page (uri-author-search)
(lambda ()
(with-request-vars* $ (name)
(if name
(let* ((conn (db:db-connection))
(authors
(row-map*
(lambda (id name)
`((author-id . ,id) (author-name . ,name)))
(db:get-authors conn name)))
(subscriptions (subscriptions conn))
(author-subscriptions
(filter (lambda (s) (equal? (alist-ref 'type s) 'author))
subscriptions)))
(waffle-sxml->html
`(select-interests-items
(@ (items ,authors) (text-key author-name) (title "Authors")
(selected ,(map
(lambda (sub)
(alist-ref 'value sub))
author-subscriptions))
(type "author") (id-key author-id) (show #t)))))
""))))
(define-page (uri-not-interested-trampoline)
(lambda ()
(with-request-vars* $ ((type as-symbol) id)
(when (and (eq? type 'tag) id)
(with-transaction (db:db-connection)
(lambda ()
(db:remove-tag-from-user (db:db-connection) ($session 'user-id) id)))))
(redirect-to (uri-site-root)))
method: 'POST)
(defpage (uri-account-create)
(lambda (conn)
`(app
(top-bar (@ (subscriptable #f) (filterable #f)))
,@(if ($ 'account-exists #f)
`((row (col (@ (small 10 (small-offset 1) (medium 4) (medium-offset 4)))
(center "Error: account exists"))))
'())
,@(if ($ 'password-or-email-too-short #f)
`((row (col (@ (small 10 (small-offset 1) (medium 4) (medium-offset 4)))
(center "Error: password or email too short. Password must be at least 12 characters."))))
'())
(row (col (@ (small 10) (small-offset 1)
(medium 4) (medium-offset 4))
(h3 "Create an account")))
(row
(col (@ (small 10) (small-offset 1)
(medium 4) (medium-offset 4))
(form (@ (action ,(uri->string (uri-account-create-trampoline)))
(method "POST"))
(input (@ (type "email") (name "email") (placeholder "email")))
(input (@ (type "password") (name "password")
(placeholder "password")))
(br)
"Also subscribe to:"
(br)
(label
(input (@ (type "checkbox") (name "breakingnews") (checked)))
" customized breaking news emails")
(br)
(label
(input (@ (type "checkbox") (name "productupdates") (checked)))
" kabonky product updates")
(spacer (@ (placement horizontal)))
(row (@ (no-padding #t))
(col (@ (small 10) (small-offset 1))
(button (@ (type "submit") (class "expand button"))
"Create account")))))
(col-end))
(spacer (@ (placement horizontal)))
(row
(col (@ (small 12) (class "center"))
(a (@ (href ,(uri->string (uri-account-sign-in))) (class "font small"))
"Already have an account?"))))))
(defpage (uri-account-sign-in)
(lambda (conn)
`(app
(top-bar (@ (subscriptable #f) (filterable #f)))
,@(if ($ 'invalid-email-or-password #f)
`((row (col (@ (small 10 (small-offset 1) (medium 4) (medium-offset 4)))
(center "Error: invalid password or account does not exist"))))
'())
(row (col (@ (small 10) (small-offset 1)
(medium 4) (medium-offset 4))
(h3 "Sign in")))
(row
(col (@ (small 10) (small-offset 1)
(medium 4) (medium-offset 4))
(form (@ (action ,(uri->string (uri-account-sign-in-trampoline)))
(method "POST"))
(input (@ (type "email") (name "email") (placeholder "email")))
(input (@ (type "password") (name "password")
(placeholder "password")))
(row (@ (no-padding #t))
(col (@ (small 6))
(label (@ (class "right"))
(a (@ (href ,(uri->string (uri-account-password-reset)))
(class "font small"))
"forgot password?"))))
(spacer (@ (placement horizontal)))
(row (@ (no-padding #t))
(col (@ (small 10) (small-offset 1))
(button (@ (type "submit") (class "expand button"))
"Sign in")))
(spacer (@ (placement horitontal)))
(row (@ (no-padding #t))
(col (@ (small 12) (class "font small center"))
"Don't have an account? "
(a (@ (href ,(uri->string (uri-account-create)))) "Sign Up")))))
(col-end)))))
(define-widget-page (uri-account-create-trampoline)
(lambda ()
(with-request-vars* $ (email password breakingnews productupdates)
(maybe-create-session)
(handle-exceptions
exn
(if (db:account-exists-condition-predicate exn)
(redirect-to (update-uri
(uri-account-create)
query: '((account-exists . #t))))
(abort exn))
(when (or (not (string? password)) (< (string-length password) 12)
(not (string? email)) (< (string-length email) 5))
(redirect-to (update-uri
(uri-account-create)
query: '((password-or-email-too-short . #t)))))
(with-transaction (db:db-connection)
(lambda ()
(create-account (db:db-connection) email password)))
(with-transaction (db:db-connection)
(lambda ()
(sign-in-user (db:get-user-id-by-email (db:db-connection) email))))
(handle-exceptions
exn
;; TODO handle better
(debug "failed to sign user up for email")
(when (and email (or breakingnews productupdates))
(when productupdates
(subscribe-to-mailing-list email))
(when breakingnews
(with-transaction (db:db-connection)
(lambda ()
(db:add-to-breaking-news-email
(db:db-connection) ($session 'user-id) (sid) email)))))))
(redirect-to (uri-site-root))))
method: 'POST)
(define-widget-page (uri-account-sign-in-trampoline)
(lambda ()
(let ((valid #f))
(with-db
(lambda (conn)
(set! valid (valid-password? conn ($ 'email) ($ 'password)))
(when valid (sign-in-user (db:get-user-id-by-email conn ($ 'email))))))
(if valid
(redirect-to (uri-site-root))
(redirect-to
(update-uri (uri-account-sign-in)
query: '((invalid-email-or-password . "true")))))))
method: 'POST)
(defpage (uri-account-password-reset)
(lambda (conn)
'(center "If you forgot your password please email t@thintz.com.")))
(defpage (uri-doc-api-landing)
(lambda (conn)
`(app
(top-bar (@ (show-menu #f) (show-personalize #f)))
(row (@ (col (small 12))) (spacer))
(div
(@ (id "api-landing-background-container"))
(row
(col
(@ (small 12))
(div (@ (class "api-landing-background") (id "api-landing-background-image")))
(div (@ (class "api-landing-background")
(id "api-landing-background-overlay"))
(div (@ (id "api-landing-background-credits-container"))
"photo by "
(a (@ (href "https://flic.kr/p/boQRU2"))
"Silecyra")
" : "
(a (@ (href "https://creativecommons.org/licenses/by/2.0/"))
"CC by 2.0")))))
(row
(@ (id "api-landing-background-text-container"))
(col (@ (small 12))
(h1 "Kabonky News API")
(h3 "The simplest, quickest way to build a news aggregator or reader."))))
(row
(@ (class "request-invite-row tall"))
(col (@ (small 10) (small-offset 1) (medium 4) (medium-offset 2))
(a (@ (name "get-invited")))
(h2 "Coming soon!")
(h5 "Be at the front of the line, request an invite now."))
(col (@ (small 10) (small-offset 1) (medium 4) (id "get-invited-column"))
(spacer)
(center
(form (@ (id "request-invite-form")
(target ,(uri->string (uri-get-invited))))
(input (@ (type "email") (placeholder "email address")
(id "request-invite-email-address") (required)))
(button (@ (class "button") (type "submit")
(id "request-invite-button"))
"Request invite")))
(spacer))
(col (@ (small 10) (small-offset 1) (medium 4)
(id "get-invited-success-column") (class "display-none"))
(spacer)
(center
(h4 "Awesome! You've been added to the invite list and you will hear from us soon."))
(spacer))
(col-end))
(row
(@ (class "tall"))
(col (@ (small 12))
(center
(h2 "Focus on your product, not the tedium.")
(h4 (i "No more feed syncing, processing, deduping, or databases; just the content."))
(p
"Retrieve articles by source, topic, or author. Order by date or relevance. It couldn't be easier."))))
(row
(@ (class "tall"))
(col (@ (small 12))
(center
(h2 "See it in action")
(p "The "(a (@ (href "/")) "kabonky news aggregator")
" already uses an early version of the API."))))
(row
(col (@ (small 12))
(center (h2 "What does it look like?")
(p (@ (class "small-font"))
(em "Note that the API is still in draft and may change.")))))
(row
(col (@ (small 12))
(h4 "First, let's get some articles")))
(row
(col (@ (small 12))
"We use a HTTP request:"))
(row
(col (@ (small 12))
(p
(code/highlight
(@ (lang "javascript"))
"httpClient.get({
url: 'https://kabonky.com/api/v0/articles',
query: {
sources: ['newshackers'], orderBy: 'date desc', type: 'text', limit: 10 }
});"))))
(row
(col (@ (small 12))
(p "Which returns:")))
(row
(col (@ (small 12))
(code/highlight
(@ (lang "javascript"))
"[{ title: 'Microsoft and Apple merge',
description: 'Everyone knew the day was coming when the two tech giants would marry...',
authors: [{ name: 'Jean-Luc Picard', id: 387 },
{ name: 'James T. Kirk', id: 386 }],
images: [{
url: 'godzilla.png',
type: 'png',
width: 1000,
height 1000,
id: 8 }]
order: 0
id: 23},
{ title: 'Reddit is rewritten from scratch in lisp',
id: 911,
order: 1,
... },
...]")))
(row (@ (col (small 12))) (hr))
(row
(col (@ (small 12))
(h4 "Get the authors of an article")))
(row
(col (@ (small 12))
(code/highlight
(@ (lang "javascript"))
"httpClient.get({
url: 'https://kabonky.com/api/v0/article/1337',
query: {
fields: ['author']}
});")))
(row (@ (col (small 12))) (br))
(row (col (@ (small 12)) (p "Which returns:")))
(row
(col (@ (small 12))
(code/highlight
(@ (lang "javascript"))
"authors: [
{ name: 'Bill Gates', id: 987 },
{ name: 'Paul Graham', id: 986 },
{ name: 'Alan Turing', id: 985 }]")))
(row (@ (col (small 12))) (hr))
(row
(col (@ (small 12))
(h4 "Get articles by topic; order by relevance")))
(row
(col (@ (small 12))
(code/highlight
(@ (lang "javascript"))
"httpClient.get({
url: 'https://kabonky.com/api/v0/articles',
query: {
topics: ['machine learning'],
fuzzyMatch: true,
orderBy: 'relevance' }
});")))
(row
(col (@ (small 12))
(p "Get articles about a specific topic or topics.")
(dl
(dt (code "fuzzyMatch [boolean]"))
(dd "If fuzzyMatch is false only articles that contain the topic text verbatim will be returned. If fuzzyMatch is true then all articles related to the topic will be returned even if it does not contain the topic keywords. For example: 'machine learning' would also include articles about neural networks.")
(dt (code "orderBy [keyword]"))
(dd "orderBy 'relevance' will place more important news above minor articles, such as the Microsoft-Apple merger coming before the article on the snail race. orderBy 'date desc|asc' will sort the articles by date in descending or ascending order."))))
(row
(col (@ (small 12))
(h4 "These are just a few examples.")
(p (a (@ (href "#get-invited")) "Get invited")
" to learn more and be one of the first to experience the ease.")))
(row
(@ (class "tall"))
(col (@ (small 12))
(center (h2 "What do we do for you?")
(h4 "RSS and Atom feeds are often a mess."))
(p "There are many issues with RSS/Atom feeds. The date field may be in an incorrect format, the author field may contain HTML, the description might contain the images or they might be in media elements, and the guid field might change for the same article across fetches. We handle all of that and much more for you so you can focus on your users. We also make it easy to fetch articles by topic, even if a feed doesn't exist for it.")))
(row
(@ (class "tall"))
(col (@ (small 12))
(center (h2 "And there's more!")
(h4 (a (@ (href "#get-invited")) "Get invited")
" and receive product updates and be one of the first to take advantage."))))
(script (@ (src "/res/js/code-highlight.js")))
(script (literal "hljs.initHighlightingOnLoad();"))))
header: (lambda () (display "")))
(define-page (uri-source-change-trampoline)
(lambda ()
(with-request-vars* $ ((sources as-list))
(when (not (null? sources))
(let ((_sources (map string->number sources)))
(with-transaction (db:db-connection)
(lambda ()
(set-user-sources! (db:db-connection)
(filter
(lambda (source)
(member (alist-ref 'source-id source) _sources))
*sources*)))))))
(redirect-to (or (header-value 'referer (request-headers (current-request)))
(uri-site-root))))
method: '(GET POST))
(define-widget-page (uri-account-sign-out)
(lambda ()
(delete-cookie! (session-cookie-name) path: (uri-reference "/"))
(redirect-to (uri-site-root))))
;; Being "topic" it should handle tag groups as well
(define (subscribe-topic conn tag)
(with-transaction conn
(lambda ()
(let* ((user-tags (user-tags conn (user-id))))
(when (and (not (member tag user-tags))
(null? (db:get-possible-user-sources-for-tag conn (user-id) tag)))
(db:add-all-sources-for-tag-for-user! conn (user-id) tag))
(let* ((_user-sources (db:get-user-sources conn (user-id)))
(user-sources (if (null? _user-sources)
(default-possible-sources)
_user-sources))
(user-sources-ids (map (cut alist-ref 'source-id <>) user-sources)))
(for-each
(lambda (source)
(let ((new-tag (not (member tag user-tags))))
(when (and (or new-tag (member tag user-tags))
(or new-tag
(not (member (alist-ref 'source-id source)
user-sources-ids))))
(subscribe conn type: 'tag value: tag
source-id: (alist-ref 'source-id source)
source-name: (alist-ref 'name source)))))
user-sources))))))
(define (unsubscribe-topic conn topic)
(with-transaction conn
(lambda ()
(db:user-tag-unsubscribe! conn topic (user-id)))))
(define (subscribe-source conn source-id)
(with-transaction conn
(lambda ()
(db:add-user-source! conn source-id (user-id)))))
(define (unsubscribe-source conn source-id)
(with-transaction conn
(lambda ()
(db:remove-user-source! conn source-id (user-id)))))
(define-widget-page (uri-subscribe)
(lambda ()
(with-request-vars* $ (source-name
value (type as-symbol) (value-id as-number)
(source-id as-number))
(with-db
(lambda (conn)
(cond ((eq? type 'topic)
(subscribe-topic conn value))
((eq? type 'source)
(subscribe-source conn source-id))
(else
(subscribe conn type: type value: value value-id: value-id
source-id: source-id source-name: source-name)))))))
method: 'POST)
(define-widget-page (uri-unsubscribe)
(lambda ()
(with-request-vars* $ (source-name
value (type as-symbol) (value-id as-number)
(source-id as-number))
(with-db
(lambda (conn)
(cond ((eq? type 'topic)
(unsubscribe-topic conn value))
((eq? type 'source)
(unsubscribe-source conn source-id))
(else
(unsubscribe conn type: type value: value value-id: value-id
source-id: source-id source-name: source-name)))))))
method: 'POST)
(define-widget-page (uri-article-viewed)
(lambda ()
(with-db
(lambda (conn)
(mark-article-viewed conn (string->number ($ 'id))))))
method: 'POST)
(define-widget-page (uri-up-vote)
(lambda ()
;; TODO change to new session system
($session-set! 'up-voted (cons (string->number ($ 'id))
($session 'up-voted '())))
(with-transaction (db:db-connection)
(lambda ()
(db:upvote-article (db:db-connection) (string->number ($ 'id)))
(when (signed-in? conn (sid))
(db:set-article-for-user-upvoted!
conn ($session 'user-id) (string->number ($ 'id)))))))
method: 'POST)
(define-widget-page (uri-account-hide-viewed)
(lambda ()
(with-transaction (db:db-connection)
(lambda ()
(db:set-user-setting!
(db:db-connection) ($session 'user-id) 'unviewed-only #t)))
(redirect-to (or (header-value 'referer (request-headers (current-request)))
(uri-site-root))))
no-session: #t)
(define-widget-page (uri-account-show-viewed)
(lambda ()
(with-transaction (db:db-connection)
(lambda ()
(db:set-user-setting!
(db:db-connection) ($session 'user-id) 'unviewed-only #f)))
(redirect-to (or (header-value 'referer (request-headers (current-request)))
(uri-site-root))))
no-session: #t)
(define-widget-page (uri-subscribe-to-mailing-list)
(lambda ()
(with-request-vars* $ (email news product)
(when (and email (or news product))
(when product
(subscribe-to-mailing-list email))
(when news
(with-transaction (db:db-connection)
(lambda ()
(db:add-to-breaking-news-email
(db:db-connection) ($session 'user-id) (sid) email)))))))
method: 'POST)
(define-widget-page (uri-get-invited)
(lambda ()
(with-request-vars* $ (email)
(when email
(with-transaction
(db:db-connection) (lambda () (db:add-to-get-invited (db:db-connection) email))))))
method: 'POST)
(widget
'text-input
``(input (@ (type "text") (name ,form-name) (value ,value) ,@attrs))
'((form-name "") (value "") (attrs ())))
(widget
'label+input-text
``(label ,@contents (text-input (@ (form-name ,form-name) (value ,value)
(attrs ,attrs))))
'((form-name "") (value "") (attrs ())))
(widget
'spaced-container
``(div (@ (class ,(++ "spaced-container" (if collapse " collapse" "")))) ,@contents)
'((collapse #t)))
(widget
'input-container
``(spaced-container (div (@ (class "input-container")) ,@contents))
'())
(widget
'icon
``(span (@ (class ,(++ "fa fa-" icon " " class))))
'((icon "") (class "")))
(widget
'icon-button
``(button (@ (class "icon-button") (id ,id)) (icon (@ (icon ,icon))))
'((icon "") (id "")))
(print "news running...")
(root-path ".")
(server-port (alist-ref 'port *program-config*))
(error-log "error-log")
(debug-log "debug-log")
(access-log "access-log")
(trusted-proxies '("172.16.1.1"))
;; feature 'not-interactive is set when not running in something like
;; emacs.
(if (not (feature? 'csi))
(server-start)
(thread-start! (lambda () (server-start))))