path: root/main.scm

(import (chicken format) (srfi-1))
(import spiffy intarweb uri-common html-parser (chicken port))
(import spiffy-request-vars)
(import (chicken io))
(import sqlite3)
(import sql-null)
(import srfi-69)
(import (chicken random))
(import (chicken process-context))
(import (chicken irregex))


;; db open and create

(define db (open-database (or (get-environment-variable "DB_FILE") "/tmp/54itter.db")))

(when (zero? (first-result db "SELECT count(*) FROM sqlite_master WHERE type='table' AND name='posts'"))
    (execute db "CREATE TABLE posts (
                    id TEXT PRIMARY KEY,
                    user_id TEXT,
                    content TEXT,
                    created_at DATETIME default current_timestamp,
                    parent_id TEXT
                )")
    (execute db "CREATE TABLE flush_votes (
                    user_id TEXT PRIMARY KEY,
                    created_at DATETIME default current_timestamp
                )")
    )

(define (create-post user content parent-id)
  (let ([id (pseudo-random-integer 281474976710655)])
    (if (and parent-id (not (equal? "" parent-id)))
      (execute db "insert into posts (id, user_id, content,parent_id) values (?, ?, ?, ?)"
               id user content parent-id)
      (execute db "insert into posts (id, user_id, content) values (?, ?, ?)"
               id user content))))

(define (vote-to-flush user)
    (execute db "insert or ignore into flush_votes (user_id) values (?)"
             user))
(define (unvote user)
    (execute db "delete from flush_votes where user_id = ?" user))


(define (vote-count) (first-result db "SELECT count(*) FROM flush_votes"))

(define (user-has-voted user) (= 1 (first-result db
                                        "SELECT count(*) FROM flush_votes WHERE user_id = ?"
                                        user)))

;;

;(define (read-request-string request)
;  (let* ((p (request-port request))
;        (len (header-value 'content-length (request-headers request)))
;        (port (request-port request)))
;                    (read-u8vector len port)))

(define (top-posts) (map-row list db
            "SELECT p.id, p.user_id, p.content, p.created_at, p.parent_id, count(c.id)
                FROM posts p
                LEFT JOIN posts c ON c.parent_id = p.id
                WHERE p.parent_id IS NULL
                GROUP BY p.id, p.user_id, p.content, p.created_at, p.parent_id
                ORDER BY count(c.id) DESC, p.created_at DESC LIMIT 25"))



(define (get-post post-id)
  (first-row db 
                "SELECT p.id, p.user_id, p.content, p.created_at, p.parent_id, count(c.id)
                    FROM posts p
                    LEFT JOIN posts c ON c.parent_id = p.id
                    WHERE p.id = ?
                    GROUP BY p.id, p.user_id, p.content, p.created_at, p.parent_id
                    ORDER BY count(c.id) DESC LIMIT 1"
                post-id))

(define (get-child-posts post-id)
    (map-row list db
            "SELECT p.id, p.user_id, p.content, p.created_at, p.parent_id, count(c.id)
                FROM posts p
                LEFT JOIN posts c ON c.parent_id = p.id
                WHERE p.parent_id = ?
                GROUP BY p.id, p.user_id, p.content, p.created_at, p.parent_id
                ORDER BY count(c.id) DESC, p.created_at ASC LIMIT 25" post-id))

(define (delete-post post-id current-user)
  (first-result db "DELETE FROM posts
                WHERE id = ? AND user_id = ?
                RETURNING parent_id" post-id current-user))

;(define (top-posts) (map-row list db
;            "SELECT id, user_id, content, created_at
;                FROM posts
;                WHERE parent_id IS NULL
;                ORDER BY created_at DESC LIMIT 25"))


(define (id p) (first p))
(define (user p) (second p))
(define (content p) (third p))
(define (created-at p) (fourth p))
(define (parent-id p) (fifth p))
(define (children-count p) (sixth p))

(define users (alist->hash-table '(("lawrence" . "pw") ("demo" . "pw") ("dan" . "pw"))))

(define apikeys (make-hash-table))

(define (login username password)
  (let ([apikey (number->string (pseudo-random-integer 340282366920938463463374607431768211455))])
      (hash-table-set! apikeys apikey username)
      apikey))

(define (lookup-user apikey) (hash-table-ref/default apikeys apikey #f))

(define (get-current-user)
  (let* ([headers (request-headers (current-request))]
         [cookie (header-value 'cookie headers)]
         [apikey (if cookie (cdr cookie) #f)])
    (if apikey (lookup-user apikey) #f)))

(define (post-path id) 
  (if
    (and id
         (not (sql-null? id))
         (not (equal? "" id)))
    (string-append "/posts/" id)
    "/"))

(define (post current-user p)
    (let ([uri (string-append "/posts/" (id p))])
      `(div (@ [class "post"] [id ,(id p)])
            ,(if (equal? current-user (user p))
                          `(a (@ [href ,(string-append
                                          uri
                                          "/delete"
                                          )]
                                 [class "delete-button"])
                              "[delete]")
                          '())
            (p (@ [style "min-height:0.5em"]) ,(content p))
            (div [@ (class "post-info")]
                 (em "- " ,(user p))
                 (span (@ [style "float:right;"])
                       (a (@ [href ,uri] [style "margin-right:2px;"])
                          "[" ,(children-count p) " comments]")
                       ,(created-at p)
                       )))))

(define (new-post-form parent-id)
  `(form (@ [class "new-post-form"] [action "/"] [method "POST"])
         (input (@ [type "hidden"]
                   [id "parent_id"]
                   [name "parent_id"]
                   [value ,(or parent-id "")]))
  (span 
      (textarea (@ [id "content"] [name "content"] [value ""] [rows "5"] [cols "50"])))
  (input (@ [id "submit"] [type "submit"] [value "Post"]))))

(define (page inner) 
  (with-output-to-string (lambda ()
    (sxml-display-as-html
      `(html (head
               (link (@ [rel "stylesheet"] [href "/style.css"]))
               (meta (@ [name "viewport"] [content "width=device-width, initial-scale=1"])))
             (body
;               (h1 "Title")
;               (a (@ [href "/"]) "Back")
               ,inner
               ))))))

(define login-form
  `(form (@ [class "login-form"] [action "/login"] [method "POST"])
    (div
  (div (label (@ [for "username"]) "Username:")
      (input (@ [type "text"] [id "username"] [name "username"] [value ""])))
  (div (label (@ [for "password"]) "Password:")
      (input (@ [type "password"] [id "password"] [name "password"] [value ""])))
  (input (@ [id "submit"] [type "submit"] [value "Submit"])))))

(define (vote-to-flush-prompt)
  (let ([prompts '("Flush it all away!"
                   "Drain the swamp!"
                   "Unclog the bog!"
                   "Vote for a Purge!")])
    (list-ref prompts (pseudo-random-integer (length prompts)))))


(define (get-route-param route param)
  (let ([pattern (second route)]
        [path (uri-path (request-uri (current-request)))])
  (first (find
           (lambda (x) (equal? (second x) (string-append ":" param)))
           (zip path pattern)))))

(define (posts-page-outer current-path current-user inner)
  (page `(div
           (em "Even Shitter than Twitter")
           (br)
           ,(if current-user
              (if (user-has-voted current-user)
                `(a (@ [href ,(string-append "/unvote?next=" current-path)])
                       unvote)
                `(a (@ [href ,(string-append "/vote-to-flush?next=" current-path)])
                    ,(vote-to-flush-prompt)))
              '())
           (div "Votes so far: " ,(vote-count))
           (div ,inner))))

(define (posts-page current-user displayed-posts)
  (posts-page-outer "/" current-user
                    `(span
                     ,(navbar current-user '(h2 "Posts"))
                       ,(if current-user (new-post-form #f) '())
                       ,(if (null? displayed-posts)
                          "no posts yet!"
                          (map (cut post current-user <>) displayed-posts))
                       )))

(define (navbar current-user . inner)
  `(div (@ [class "navbar"])
        ,(if current-user
                '(a (@ [style "float:right;"] [href "/logout"]) logout)
                '(a (@ [style "float:right;"] [href "/login"]) login))
        ,inner
       ))

(define (post-page current-user p comments)
  (let* ([current-path (post-path (id p))]
         [pid (parent-id p)]
         [parent-path (if (or (not pid)
                              (sql-null? pid)
                              (equal? pid ""))
                        "/"
                        (string-append "/posts/" pid))])
    (posts-page-outer current-path current-user
                      `(span
                         ,(navbar current-user
                                  `(a (@ [href ,parent-path])
                                      "return"))
                      ,(post current-user p)
                      (h3 "Comments")
                      ,(if (null? comments)
                         "no comments yet!"
                         (map (cut post current-user <>) comments))
                      ,(if current-user (new-post-form (id p)) '())))))

(define (get-next-path)
  (let ([next ((request-vars 'query-string) 'next as-string)])
    (if (irregex-match "^/posts/[0-9]*$" next)
      next
      "/")))


(define routes
  `(
    (GET (/ "style.css") ,(lambda (rt)
                              (send-static-file "style.css")))
    (GET (/ "favicon.ico") ,(lambda (rt)
                              (send-static-file "favicon.ico")))
    (GET (/ "unvote") ,(lambda (rt)
                            (unvote (get-current-user))
                           (send-response
                             headers: `((location ,(get-next-path)))
                             status: 'see-other
                             )))
    (GET (/ "vote-to-flush") ,(lambda (rt)
                            (let ([user (get-current-user)]) (when user (vote-to-flush user)))
                            (send-response
                              headers: `((location ,(get-next-path)))
                              status: 'see-other
                              )))
    (GET (/ "login") ,(lambda (rt) (send-response
                               headers: '((content-type text/html))
                               status: 'ok
                               body: (page `(div
                                              (a (@ [style "float:right;"] [href "/"]) back)
                                              (h2 "Login")
                                              ,login-form)))))
    (POST (/ "login") ,(lambda (rt)
                         (let* ([form-data (read-urlencoded-request-data (current-request))]
                                [username (cdr (assv 'username form-data))]
                                [password (cdr (assv 'password form-data))]
                                [apikey (login username password)])
                           (send-response
                             headers: `((location "/")
                                        (set-cookie
                                          #(("apikey" . ,apikey) ())))
                             status: 'see-other))))
    (GET (/ "logout") ,(lambda (rt)
                           (send-response
                             headers: `((location "/")
                                        (set-cookie
                                          #(("apikey" . "") ()))) ; should also wipe server-side keys
                             status: 'see-other
                             )))
    (POST (/ "") ,(lambda (rt)
                    (let* ([form-data (read-urlencoded-request-data (current-request))]
                           [content (cdr (assv 'content form-data))]
                           [parent-id (cdr (assv 'parent_id form-data))]
                           [user (get-current-user)]
                           [success? (if user (create-post user content parent-id) #f)])
                        (send-response
                               headers: `((location ,(post-path parent-id)))
                               status: 'see-other
                               ))))
    (GET (/ "") ,(lambda (rt) 
                   (let ([current-user (get-current-user)]
                         [displayed-posts (top-posts)])
                     (send-response
                       headers: '((content-type text/html))
                       status: 'ok
                       body: (posts-page current-user displayed-posts)))))

    (GET (/ "posts" ":id") ,(lambda (rt) 
                              (let* ([current-user (get-current-user)]
                                     [post-id (get-route-param rt "id")]
                                     [post (get-post post-id)]
                                     [comments (get-child-posts post-id)])
                                (send-response
                                  headers: '((content-type text/html))
                                  status: 'ok
                                  body: (post-page current-user post comments)))))
    ; Has method GET so that it can be used from <a> tag links
    (GET (/ "posts" ":id" "delete") ,(lambda (rt) 
                              (let* ([current-user (get-current-user)]
                                     [post-id (get-route-param rt "id")]
                                     [parent-id (delete-post post-id current-user)])
                                (if parent-id
                                (send-response
                                  headers: `((location ,(post-path parent-id)))
                                  status: 'see-other)
                                (send-status 'internal-server-error "Deletion Failed")))))

    (GET (/ "posts") ,(lambda (rt)
                        (send-response
                          headers: `((location "/"))
                          status: 'see-other
                          )))

    ))

(define (route-patterns-match? req pat)
  (and (= (length req) (length pat))
       (every
         (lambda (xy)
           (let ([x (first xy)] [y (second xy)])
             (or (equal? x y)
                 (and (string? y) (< 0 (string-length y))
                      (equal? #\: (string-ref y 0))))))
         (zip req pat))))

(define (find-route uri method)
  (find
           (lambda (r) (and
                         (equal?
                           method
                           (first r))
                         (route-patterns-match?
                           (uri-path uri)
                           (second r))))
           routes))
 
(define (handle continue)
  (let* ((uri (request-uri (current-request)))
         (method (request-method (current-request)))
         (route (find-route uri method)))
    (if route
      ((third route) route)
      (begin (display uri ) (display method) (send-status 'not-found "Page Not Found")))))

(root-path ".")
(vhost-map `((".*" . ,handle)))
(start-server port: 7080)