path: root/main.scm

(import
  scheme (chicken base)
  (chicken format) (chicken port) (chicken random) (chicken time)
  (chicken process-context) (chicken irregex) (chicken condition) (chicken blob)
  spiffy intarweb uri-common html-parser spiffy-request-vars multipart-form-data
  sqlite3 sql-null
  srfi-69 ;hash tables
  srfi-1 ;list functions
  srfi-4 ;u8vector
)


;; 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 (gen-id)
  (+ (pseudo-random-integer 65536)
     (* (current-seconds) 100000)))

(define (create-post user content parent-id)

  (let ([id (gen-id)]
        [parent-id-or-null (if (or (not parent-id) (eof-object? parent-id) (equal? "" parent-id))
                                (sql-null)
                                parent-id)]
        [content-or-empty (if (or (not content) (eof-object? content))
                            ""
                            content)])
      (execute db "insert into posts
                    (id, user_id, content, parent_id)
                    values (?, ?, ?, ?)"
               id user content-or-empty parent-id-or-null)))

(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 (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)
   (condition-case (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)
    [(exn sqlite3) #f]))


(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 "
             post-id
             ))

(define (get-user-posts user-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 IS NULL AND p.user_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 DESC LIMIT 25" user-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 (has-image? p) (= 1 (seventh p)))

(foreign-declare "#include \"exif_wrapper.h\"")

(define (get-exif-orientation raw-img-vec)
  ((foreign-lambda unsigned-int "getExifOrientation" u8vector unsigned-int)
   raw-img-vec
   (u8vector-length raw-img-vec)))

(define (set-exif-orientation raw-img orientation)
  (let-values
    ([(fd file-path) (file-mkstemp "/tmp/image-temp.XXXXXX")])
    (file-write fd raw-img)
    (file-close fd)
    ((foreign-lambda void "setExifOrientation" nonnull-c-string unsigned-int)
     file-path
     orientation)
    (let*
      ([port (open-input-file file-path #:binary)]
       [result (u8vector->blob/shared (read-u8vector #f port))])
      (delete-file file-path)
      result)))

(define dim-max 512)

(define (target-dimensions width height)
  ; case: both within limits -> return values
  (if (and (> dim-max width) (> dim-max height))
    (values width height)
    ; case: either larger -> scale largest down to limit, scale smallest down by same amount
  (let* (
         [width-is-bigger (> width height)]
         [big-dim (if width-is-bigger width height)]
         [small-dim (if width-is-bigger height width)]
         [scale-factor (quotient big-dim dim-max)]
         [scaled-small-dim (quotient small-dim scale-factor)])
    (if width-is-bigger
      (values dim-max scaled-small-dim)
      (values scaled-small-dim dim-max)
      ))))

(define (img->jpeg-blob img)
  (and img
       (let*-values
         ([(orientation) (get-exif-orientation img)]
          [(raw width height channels) (load-image img)]
          [(target-width target-height) (target-dimensions width height)]
          [(resized-jpg)
              (string->blob
                (with-output-to-string
                  (lambda ()
                    (write-jpg
                      (image-resize raw width height channels target-width target-height)
                      target-width
                      target-height
                      channels)
                    )))])
         (set-exif-orientation resized-jpg orientation)
         )))

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

(define apikeys (make-hash-table))

(define (login username password)
  (let ([pw-in-db (hash-table-ref/default users username #f)])
    (and password (equal? password pw-in-db)
         (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-cookie key)
  (let* ([headers (request-headers (current-request))]
         [cookies (header-values 'cookie headers)])
    (alist-ref key cookies equal?)))

(define (get-current-user)
  (let ([apikey (get-cookie "apikey")])
    (if apikey (lookup-user apikey) #f)))

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

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

(define (get-opt opt opts) (find (cut equal? <> opt) opts))

(define (content->sxml content)
  (let ([r "(https://[^ ]*)"])
    (if (irregex-search r content)
      (let* ([starts-with-link (= 0 (irregex-match-start-index (irregex-search r content)))]
             [texts (map (cut list 'span <>) (irregex-split r content))]
             [links (map (lambda (x)
                           `(a (@ [href ,x]
                                  [target "_blank"]
                                  [rel "noreferrer"])
                               ,x)) (irregex-extract r content))])
        (define (go xs ys take-y?)
          (cond
            [(and (not (null-list? ys)) take-y?)
             (cons (car ys) (go xs (cdr ys) #f))]
            [(and (not (null-list? xs)) (not take-y?))
             (cons (car xs) (go (cdr xs) ys #t))]
            [else '()]
            ))
        (go texts links starts-with-link))
      `(p ,content))))

(define (post current-user p . opts)
    (let ([uri (post-path (id p))]
          [hide-comments-link (get-opt 'hide-comments-link opts)])
      `(div (@ [class "post"] [id ,(id p)])
            ,(if (equal? current-user (user p))
                          `(a (@ [href ,(string-append
                                          uri
                                          "/delete"
                                          )]
                                 [class "delete-button"])
                              "[delete]")
                          '())
            (div (@ [class "content-container"]) ,(content->sxml (content p)))
            (div (@ [class "post-info"])
                 (em "- " (a (@ [href ,(user-path (user p))]) ,(user p)))
                 (span (@ [style "float:right;"])
                       ,(if hide-comments-link '() `(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"]
            [enctype "multipart/form-data"])
         (input (@ [type "hidden"]
                   [id "parent_id"]
                   [name "parent_id"]
                   [value ,(or parent-id "")]))
  (span
      (textarea (@ [maxlength "540"]
                   [id "content"]
                   [name "content"]
                   [value ""]
                   [rows "5"]
                   [cols "50"])))
  (input (@ [id "submit"] [type "submit"] [value "Post"]))
  ))

(define (page inner)
  (string-append
    "<!DOCTYPE html>"
    (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
                   ,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!"
                   "Unclog the bog!"
                   "Incinerate everything!"
                   "Vote for a Purge!")])
    (list-ref prompts (pseudo-random-integer (length prompts)))))

(define (current-request-path) (uri-path (request-uri (current-request))))

(define (get-route-param route param)
  (let ([pattern (second route)]
        [path (current-request-path)])
  (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 (user-page current-user user posts)
  (posts-page-outer (user-path user) current-user
                    `(span
                       ,(navbar current-user '(a (@ [href "/"]) "home"))
                       (h2 ,user)
                       ,(if (and current-user (equal? current-user user)) (new-post-form #f) '())
                       ,(if (null? posts)
                          "no posts yet!"
                          (map (cut post current-user <>) posts))
                       )))

(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])
                                      ,(if (equal? parent-path "/") "home" "parent")))
                      ,(post current-user p 'hide-comments-link)
                      (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)
  (get-qp-path 'next))

(define allowed-return-paths
  '("^/posts/[0-9]*$"
    "^/users/[A-z0-9_-]*$"))

(define (get-qp-path qp)
  (let ([p ((request-vars 'query-string) qp as-string)])
    (if (and p (any (cut irregex-match <> p) allowed-return-paths))
      p
      "/")))

(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)])
                           (if apikey
                             (send-response
                               headers: `((location "/")
                                          (set-cookie
                                            #(("apikey" . ,apikey) ())))
                               status: 'see-other)
                             (send-status 'unauthorized)))))

    (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-multipart-form-data (current-request))]
                           [content (cdr (assv 'content form-data))]
                           [parent-id (cdr (assv 'parent_id form-data))]
                           [user (get-current-user)]
                           [success? (and user (create-post user content parent-id))])
                        (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 (/ "users" ":id") ,(lambda (rt)
                              (let* ([current-user (get-current-user)]
                                     [user-id (get-route-param rt "id")]
                                     [posts (get-user-posts user-id)])
                                    (send-response
                                      headers: '((content-type text/html))
                                      status: 'ok
                                      body: (user-page current-user user-id 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 (and post (get-child-posts post-id))])
                                (if post
                                    (send-response
                                      headers:  '((content-type text/html))
                                      status: 'ok
                                      body: (post-page current-user post comments))
                                    (send-status 'not-found "This Post no longer exists!")))))

    ; 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)