;;;; SPDX-FileCopyrightText: 2023 Vasilij Schneidermann <mail@vasilij.de>
;;;;
;;;; SPDX-License-Identifier: GPL-3.0-or-later

(module modo ()

(import scheme)
(import (chicken base))
(import (chicken condition))
(import (chicken format))
(import (chicken io))
(import (chicken irregex))
(import (chicken port))
(import (chicken process-context))
(import (chicken string))
(import (chicken time))
(import (chicken time posix))
(import (srfi 1))
(import crypt)
(import doctype)
(import intarweb)
(import matchable)
(import medea)
(import spiffy)
(import sql-de-lite)
(import sxml-transforms)
(import uri-common)

(define web-db (make-parameter #f))
(define web-title "modo")

(define cookie-name "SESSIONID")
(define seconds-in-day (* 24 60 60))
(define cookie-rolling-duration (* 7 seconds-in-day))
(define cookie-max-duration (* 365 seconds-in-day))

;;; helpers

(define (pop-item-at items index)
  (let loop ((i 1)
             (acc '())
             (item #f)
             (items items))
    (if (pair? items)
        (let ((it (car items)))
          (if (= i index)
              (loop (add1 i) acc it (cdr items))
              (loop (add1 i) (cons it acc) item (cdr items))))
        (values item (reverse acc)))))

(define (insert-item-after items index item)
  (if (zero? index)
      (cons item items)
      (let loop ((i 1)
                 (acc '())
                 (items items))
        (if (pair? items)
            (let ((it (car items)))
              (if (= i index)
                  (loop (add1 i) (cons item (cons it acc)) (cdr items))
                  (loop (add1 i) (cons it acc) (cdr items))))
            (reverse acc)))))

(define (reorder-items items from to)
  (let ((maximum (length items)))
    (when (or (< from 1) (> from maximum)
              (< to 1) (> to maximum))
      (error "Index out of bounds")))
  (if (= from to)
      items
      (receive (item items) (pop-item-at items from)
        (insert-item-after items (sub1 to) item))))

(define (sum items)
  (fold + 0 items))

(define (db-id? str)
  (irregex-match "[0-9]{1,16}" str))

(define (http-error status #!optional json)
  (if json
      (condition `(modo status ,status json ,json) '(http))
      (condition `(modo status ,status) '(http))))

(define (send-html content #!key (status 'ok))
  (send-response body: content status: status
                 headers: '((content-type "text/html"))))

(define (send-json content #!key (status 'ok))
  (send-response body: (json->string content) status: status
                 headers: '((content-type "application/json"))))

(define (send-redirect location #!optional cookie)
  (send-response status: 'see-other
                 headers: `((location ,location)
                            ,@(if cookie
                                  (list cookie)
                                  '()))))

(define (validate-param! param predicate)
  (when (not (predicate param))
    (signal (http-error 'unprocessable-entity))))

(define (extract-json-params! request)
  (let ((headers (request-headers request)))
    (when (not (integer? (header-value 'content-length headers)))
      (signal (http-error 'unprocessable-entity)))
    (when (not (eqv? (header-value 'content-type headers) 'application/json))
      (signal (http-error 'unsupported-media-type)))
    (let* ((content-length (header-value 'content-length headers))
           (body (read-string content-length (request-port request)))
           (json (read-json body)))
      (when (not (pair? json))
        (signal (http-error 'unprocessable-entity)))
      json)))

;;; data model

(define-record <user> id username password created updated)
(define-record <session> id identifier user-id created updated)

(set! (record-printer <user>)
      (lambda (x out)
        (fprintf out "#<~a ~s>"
                 (<user>-id x) (<user>-username x))))

(set! (record-printer <session>)
      (lambda (x out)
        (fprintf out "#<~a ~s ~a>"
                 (<session>-id x) (<session>-identifier x)
                 (<session>-user-id x))))

(define (query-user username)
  (let ((row
         (query fetch-row
                (sql (web-db) "SELECT id, username, password,
                                      created, updated
                                 FROM users
                                WHERE username = ?")
                username)))
    (if (pair? row)
        (apply make-<user> row)
        #f)))

(define (query-session session-id)
  (let ((row
         (query fetch-row
                (sql (web-db) "SELECT id, identifier, user_id,
                                      created, updated
                                 FROM sessions
                                WHERE identifier = ?")
                session-id)))
    (if (pair? row)
        (apply make-<session> row)
        #f)))

(define (insert-session! session-id user-id timestamp)
  (exec (sql (web-db) "INSERT INTO sessions(identifier, user_id,
                                            created, updated)
                       VALUES(?, ?, ?, ?)")
        session-id user-id timestamp timestamp))

(define (extend-session! session-id)
  (let ((db (web-db)))
    (with-exclusive-transaction db
      (lambda ()
        (and-let* ((session (query-session session-id))
                   (updated (<session>-updated session))
                   (new-updated (increment-utc-timestamp updated cookie-rolling-duration)))

          (exec (sql (web-db) "UPDATE sessions
                                  SET updated = ?
                                WHERE identifier = ?")
                new-updated session-id))))))

(define (invalidate-session! session-id)
  (exec (sql (web-db) "DELETE FROM sessions
                        WHERE identifier = ?")
        session-id))

(define-record <list> id sid content created updated)
(define-record <todo> id sid lid content done created updated)

(set! (record-printer <list>)
      (lambda (x out)
        (fprintf out "#<~a ~a ~s>"
                 (<list>-id x) (<list>-sid x) (<list>-content x))))

(set! (record-printer <todo>)
      (lambda (x out)
        (fprintf out "#<~a ~a ~a ~s>"
                 (<todo>-id x) (<todo>-sid x) (<todo>-lid x)
                 (<todo>-content x))))

(let ((%make-<todo> make-<todo>))
  (set! make-<todo>
        (lambda (id sid lid content done created updated)
          (let ((done (if (= done 0) #f #t)))
            (%make-<todo> id sid lid content done created updated)))))

(define (<list>->json item)
  `((lid . ,(<list>-id item))
    (lsid . ,(<list>-sid item))
    (content . ,(<list>-content item))
    (created . ,(<list>-created item))
    (updated . ,(<list>-updated item))))

(define (query-lists)
  (map (lambda (row)
         (apply make-<list> row))
       (query fetch-rows
              (sql (web-db) "SELECT id, sort_id, content,
                                    created, updated
                               FROM lists
                           ORDER BY sort_id ASC"))))

(define (query-list lid)
  (let ((row
         (query fetch-row
                (sql (web-db) "SELECT id, sort_id, content,
                                      created, updated
                                 FROM lists
                                WHERE id = ?")
                lid)))
    (if (pair? row)
        (apply make-<list> row)
        #f)))

(define (query-list-count)
  (query fetch-value (sql (web-db) "SELECT COUNT(*) FROM lists")))

(define (insert-list! sort-id content timestamp)
  (exec (sql (web-db) "INSERT INTO lists(sort_id, content,
                                         created, updated)
                       VALUES(?, ?, ?, ?)")
        sort-id content timestamp timestamp))

(define (create-list! content timestamp)
  (let ((db (web-db)))
    (with-exclusive-transaction db
      (lambda ()
        (let ((sort-id (add1 (query-list-count))))
          (insert-list! sort-id content timestamp)
          (let ((lid (last-insert-rowid db)))
            (make-<list> lid sort-id content timestamp timestamp)))))))

(define (delete-list! lid)
  (exec (sql (web-db) "DELETE FROM lists
                        WHERE id = ?")
        lid))

(define (update-list! lid content timestamp)
  (exec (sql (web-db) "UPDATE lists
                          SET content = ?,
                              updated = ?
                        WHERE id = ?")
        content timestamp lid))

(define (renumber-lists! items timestamp)
  (let ((db (web-db)))
    (sum
     (map (lambda (item new-sid)
            (let ((old-sid (<list>-sid item))
                  (lid (<list>-id item)))
              (if (not (= old-sid new-sid))
                  (exec (sql db "UPDATE lists
                                    SET sort_id = ?,
                                        updated = ?
                                  WHERE id = ?")
                      new-sid timestamp lid)
                  0)))
          items (iota (length items) 1)))))

(define (reorder-list! lid to timestamp)
  (with-exclusive-transaction (web-db)
    (lambda ()
      (cond
       ((query-list lid)
        => (lambda (item)
             (let ((from (<list>-sid item))
                   (minimum 1)
                   (maximum (query-list-count)))
               (cond
                ((= from to)
                 0)
                ((= to -1)
                 (let* ((items (query-lists))
                        (to (query-list-count))
                        (reordered (reorder-items items from to)))
                   (renumber-lists! reordered timestamp)))
                ((or (< from minimum) (> from maximum)
                     (< to minimum) (> to maximum))
                 -1)
                (else
                 (let* ((items (query-lists))
                        (reordered (reorder-items items from to)))
                   (renumber-lists! reordered timestamp)))))))
       (else
        -1)))))

(define (<todo>->json item)
  `((tid . ,(<todo>-id item))
    (tsid . ,(<todo>-sid item))
    (lid . ,(<todo>-lid item))
    (content . ,(<todo>-content item))
    (done . ,(let ((done (<todo>-done item)))
               (if (or (not done) (zero? done)) #f #t)))
    (created . ,(<todo>-created item))
    (updated . ,(<todo>-updated item))))

(define (query-todos* lid)
  (map (lambda (row)
         (apply make-<todo> row))
       (query fetch-rows
              (sql (web-db) "SELECT id, sort_id, list_id, content, done,
                                    created, updated
                               FROM todos
                              WHERE list_id = ?
                              ORDER BY sort_id ASC")
              lid)))

(define (query-todos lid)
  (with-transaction (web-db)
    (lambda ()
      (if (query-list lid)
          (query-todos* lid)
          -1))))

(define (query-todo lid tid)
  (let ((row
         (query fetch-row
                (sql (web-db) "SELECT id, sort_id, list_id, content, done,
                                      created, updated
                                 FROM todos
                                WHERE list_id = ?
                                  AND id = ?")
                lid tid)))
    (if (pair? row)
        (apply make-<todo> row)
        #f)))

(define (query-todo-count lid)
  (query fetch-value
         (sql (web-db) "SELECT COUNT(*)
                          FROM todos
                         WHERE list_id = ?")
         lid))

(define (insert-todo! lid sort-id content timestamp)
  (exec (sql (web-db) "INSERT INTO todos(list_id, sort_id, content, done,
                                         created, updated)
                       VALUES(?, ?, ?, 0, ?, ?)")
        lid sort-id content timestamp timestamp))

(define (create-todo! lid content timestamp)
  (let ((db (web-db)))
    (with-exclusive-transaction db
      (lambda ()
        (let ((list (query-list lid)))
          (if list
              (let ((sort-id (add1 (query-todo-count lid))))
                (insert-todo! lid sort-id content timestamp)
                (let ((tid (last-insert-rowid db)))
                  (make-<todo> tid sort-id lid content 0 timestamp timestamp)))
              -1))))))

(define (delete-todo! lid tid)
  (exec (sql (web-db) "DELETE FROM todos
                        WHERE list_id = ?
                          AND id = ?")
        lid tid))

(define (update-todo! lid tid content timestamp)
  (exec (sql (web-db) "UPDATE todos
                          SET content = ?,
                              updated = ?
                        WHERE list_id = ?
                          AND id = ?")
        content timestamp lid tid))

(define (update-todo-done! lid tid done timestamp)
  (exec (sql (web-db) "UPDATE todos
                          SET done = ?,
                              updated = ?
                        WHERE list_id = ?
                          AND id = ?")
        done timestamp lid tid))

(define (finish-todo! lid tid timestamp)
  (update-todo-done! lid tid 1 timestamp))

(define (resurrect-todo! lid tid timestamp)
  (update-todo-done! lid tid 0 timestamp))

(define (renumber-todos! items timestamp)
  (let ((db (web-db)))
    (sum
     (map (lambda (item new-sid)
            (let ((old-sid (<todo>-sid item))
                  (lid (<todo>-lid item))
                  (tid (<todo>-id item)))
              (if (not (= old-sid new-sid))
                  (exec (sql db "UPDATE todos
                                    SET sort_id = ?,
                                        updated = ?
                                  WHERE list_id = ?
                                    AND id = ?")
                      new-sid timestamp lid tid)
                  0)))
          items (iota (length items) 1)))))

(define (reorder-todo! lid tid to timestamp)
  (with-exclusive-transaction (web-db)
    (lambda ()
      (cond
       ((query-todo lid tid)
        => (lambda (item)
             (let ((from (<todo>-sid item))
                   (minimum 1)
                   (maximum (query-todo-count lid)))
               (cond
                ((= from to)
                 0)
                ((= to -1)
                 (let* ((items (query-todos* lid))
                        (to (query-todo-count lid))
                        (reordered (reorder-items items from to)))
                   (renumber-todos! reordered timestamp)))
                ((or (< from minimum) (> from maximum)
                     (< to minimum) (> to maximum))
                 -1)
                (else
                 (let* ((items (query-todos* lid))
                        (reordered (reorder-items items from to)))
                   (renumber-todos! reordered timestamp)))))))
       (else
        -1)))))

;; NOTE: by always adjusting the updated column, it's possible to tell
;; when the browser contents are stale
;; TODO: detect this and perform UI refresh

(define (setup-db)
  (exec (sql (web-db) "PRAGMA foreign_keys=ON"))
  (exec (sql (web-db) "PRAGMA journal_mode=WAL")))

(define (close-db)
  (and-let* ((db (web-db)))
    (close-database db)
    (web-db #f)))

;;; authentication

(define (generate-cookie-header session-id cookie-attribs)
  `(set-cookie #((,cookie-name . ,session-id)
                 ,@(if cookie-attribs
                       (list cookie-attribs)
                       '()))))

(define (current-session-id request)
  (let ((cookies (header-values 'cookie (request-headers request))))
    (alist-ref cookie-name cookies equal?)))

(define (valid-credentials? user password)
  (let ((expected-password (<user>-password user)))
    (string=? (crypt password expected-password)
              expected-password)))

(define (request-authenticated? request)
  (and-let* ((now (current-seconds))
             (session-id (current-session-id request))
             (session (query-session session-id))
             (created (parse-utc-timestamp (<session>-created session)))
             (updated (parse-utc-timestamp (<session>-updated session)))
             (rolling-window (+ updated cookie-rolling-duration))
             (max-window (+ created cookie-max-duration)))
    (and (<= now rolling-window) (<= now max-window))))

(define (utc-timestamp #!optional (seconds (current-seconds)))
  (time->string (seconds->utc-time seconds) "%Y%m%dT%H%M%SZ"))

(define (cookie-expires-time)
  (seconds->utc-time (+ (current-seconds) cookie-max-duration)))

(define (parse-utc-timestamp string)
  (utc-time->seconds (string->time string "%Y%m%dT%H%M%SZ")))

(define (increment-utc-timestamp string amount)
  (utc-timestamp (+ (parse-utc-timestamp string) amount)))

(define (generate-session-id)
  (call-with-input-file "/proc/sys/kernel/random/uuid"
    (lambda (in)
      (string-translate (read-line in) "-"))))

(define (process-login request)
  (when (not ((request-has-message-body?) request))
    (print "Login attempt without form data")
    (signal (http-error 'unprocessable-entity)))
  (let* ((params (read-urlencoded-request-data request))
         (username (alist-ref 'username params))
         (password (alist-ref 'password params)))
    (when (not (and username password))
      (print "Login attempt malformed")
      (signal (http-error 'unprocessable-entity)))
    (let ((user (query-user username)))
      (if (and user (valid-credentials? user password))
          (let* ((session-id (generate-session-id))
                 (expires (cookie-expires-time)))
            (establish-session! user session-id)
            (let ((cookie (generate-cookie-header session-id
                                                  `((http-only . #t)
                                                    (same-site . strict)
                                                    (expires . ,expires)))))
              (printf "Login for ~s successful\n" username)
              (send-redirect "/" cookie)))
          (begin
            (printf "Login for ~s failed\n" username)
            (send-redirect "/login"))))))

(define (establish-session! user session-id)
  (let ((user-id (<user>-id user))
        (timestamp (utc-timestamp)))
    (insert-session! session-id user-id timestamp)))

;;; pages

(define (generate-html #!rest elements)
  (with-output-to-string
    (lambda ()
      (SRV:send-reply
       (pre-post-order
        `((doctype-html)
          (html
           (@ (lang "en"))
           (head
            (meta (@ (charset "utf-8")))
            (meta (@ (name "viewport")
                     (content "initial-scale=1.0,width=device-width,user-scalable=no")))
            (meta (@ (name "apple-mobile-web-app-capable")
                     (content "yes")))
            (title ,web-title)
            (link (@ (href "/static/style.css") (rel "stylesheet")))
            (link (@ (href "/static/bootstrap-5.3.1.min.css") (rel "stylesheet")))
            (link (@ (href "/static/fontawesome-6.4.2/css/fontawesome.min.css") (rel "stylesheet")))
            (link (@ (href "/static/fontawesome-6.4.2/css/solid.min.css") (rel "stylesheet"))))
           (body
            ,@elements
            (script (@ (src "/static/index.js")))
            (script (@ (src "/static/bootstrap-5.3.1.bundle.min.js")))
            (script (@ (src "/static/Sortable-1.15.0.min.js"))))))
        (append doctype-rules universal-conversion-rules))))))

(define (html-navigation authenticated?)
  `(header
    (nav
     (@ (class "navbar fixed-top bg-body-tertiary"))
     (div
      (@ (class "container-fluid"))
      (span (@ (class "navbar-brand mb-0 h1")) "Modo")
      ;; TODO: persist this setting
      ;; TODO: render initial view depending on the setting
      (form
       (@ (class "d-flex"))
       (div
        (@ (class "form-check form-check-inline"))
        (input (@ (class "form-check-input")
                  (type "checkbox")
                  (checked #t)
                  (id "toggleDoneItemsDisplay")
                  (onchange "modo.toggleDoneItemsDisplay(event)")))
        (label (@ (class "form-check-label")
                  (for "toggleDoneItemsDisplay"))
               "Show done items")))
      (div
       (@ (class "d-flex"))
       ,(if authenticated?
            '(a (@ (href "/logout")) "Log out")
            '(a (@ (href "/login")) "Log in")))))))

(define (login-page authenticated?)
  (generate-html
   (html-navigation authenticated?)
    '(section
      (@ (class "container my-3"))
      (form
       (@ (method "POST"))
       (div
        (@ (class "mb-3"))
        (label (@ (class "form-label") (for "username")) "Username:")
        (input (@ (class "form-control") (name "username"))))
       (div
        (@ (class "mb-3"))
        (label (@ (class "form-label") (for "password")) "Password:")
        (input (@ (class "form-control") (type "password") (name "password"))))
       (button (@ (class "btn btn-primary") (type "submit") (name "submit")) "Submit")))))

(define (index-page)
  (let* ((groups (with-transaction (web-db)
                   (lambda ()
                     (map
                      (lambda (item)
                        (let ((todos (query-todos* (<list>-id item))))
                          (cons item todos)))
                      (query-lists))))))
    (generate-html
     (html-navigation 'authenticated)
     ;; .modo-list-container
     ;; - .modo-list-new.modo-list-item
     ;; - .modo-list-items
     ;;   - .modo-list-item
     ;;     - .modo-todo-container
     ;;       - .modo-todo-new.modo-todo-item
     ;;       - .modo-todo-items
     ;;         - .modo-todo-item
     `(section
       (@ (class "modo container pt-5"))
       (div
        (@ (class "modo-list-container"))
        (div
         (@ (class "modo-list-new modo-list-item card my-3"))
         (div
          (@ (class "card-header d-flex flex-row align-items-center"))
          (input (@ (class "description px-1 me-auto")
                    (placeholder "New list")
                    (oninput "modo.updateCreateListButton(event)")))
          (button (@ (class "btn btn-secondary") (disabled #t)
                     (onclick "modo.createList(event)"))
                  (i (@ (class "fa-solid fa-folder-plus"))))))
        (div
         (@ (class "modo-list-items"))
         ,@(map
            (lambda (group)
              (let* ((item (car group))
                     (id (number->string (<list>-id item)))
                     (sid (number->string (<list>-sid item)))
                     (content (<list>-content item))
                     (todos (cdr group)))
                `(div
                  (@ (class "modo-list-item card my-3") (data-id ,id))
                  (div
                   (@ (class "card-header d-flex flex-row align-items-center"))
                   (span (@ (class "modo-list-drag-handle"))
                         (i (@ (class "fa-solid fa-arrows-up-down"))))
                   (span (@ (class "content me-auto")) ,content)
                   (button (@ (class "btn") (name "edit") (data-id ,id)
                              (onclick "modo.editList(event)"))
                           (i (@ (class "fa-solid fa-pencil"))))
                   (button (@ (class "btn btn-danger") (name "delete")
                              (data-id ,id) (onclick "modo.deleteList(event)"))
                           (i (@ (class "fa-solid fa-trash")))))
                  (div
                   (@ (class "modo-todo-container list-group"))
                   (div
                    (@ (class "modo-todo-new modo-todo-item list-group-item"))
                    (div
                     (@ (class "d-flex flex-row"))
                     (input (@ (class "description px-1 me-auto")
                               (placeholder "New todo")
                               (oninput "modo.updateCreateTodoButton(event)")))
                     (button (@ (class "btn btn-secondary")
                                (disabled #t) (data-id ,id)
                                (onclick "modo.createTodo(event)"))
                             (i (@ (class "fa-solid fa-file-circle-plus"))))))
                   (div
                    (@ (class "modo-todo-items"))
                    ,@(map
                       (lambda (item)
                         (let ((id (number->string (<todo>-id item)))
                               (lid (number->string (<todo>-lid item)))
                               (sid (number->string (<todo>-sid item)))
                               (done (<todo>-done item))
                               (content (<todo>-content item)))
                           `(div
                             (@ (class "modo-todo-item list-group-item")
                                (data-id ,id) (data-lid ,lid))
                             (div
                              (@ (class "d-flex flex-row align-items-center"))
                              (span (@ (class "modo-todo-drag-handle"))
                                    (i (@ (class "fa-solid fa-arrows-up-down"))))
                              (div
                               (@ (class "form-check form-check-inline"))
                               (input (@ (class "form-check-input")
                                         (type "checkbox")
                                         ,@(if done '((checked #t)) '())
                                         (data-id ,id) (data-lid ,lid)
                                         (onchange "modo.toggleTodo(event)"))))
                              (span (@ (class "content me-auto")) ,content)
                              (button (@ (class "btn") (name "edit")
                                         (data-id ,id) (data-lid ,lid)
                                         (onclick "modo.editTodo(event)"))
                                      (i (@ (class "fa-solid fa-pencil"))))
                              (button (@ (class "btn btn-danger") (name "delete")
                                         (data-id ,id) (data-lid ,lid)
                                         (onclick "modo.deleteTodo(event)"))
                                      (i (@ (class "fa-solid fa-trash"))))))))
                       todos))))))
            groups))))
     '(div
       (@ (class "toast-container position-fixed bottom-0 end-0 p-3"))
       (div
        (@ (class "toast align-items-center text-bg-danger border-0")
           (id "errorToast")
           (role "alert") (aria-live "assertive") (aria-atomic "true"))
        (div
         (@ (class "d-flex"))
         (div (@ (class "toast-body")) "Toast message")
         (button
          (@ (type "button")
             (class "btn-close btn-close-white me-2 m-auto")
             (data-bs-dismiss "toast") (aria-label "Close")))))))))

;;; list API

(define (process-get-lists _request)
  (send-json
   (list->vector
    (map <list>->json (query-lists)))))

(define (process-create-list! request)
  (let ((content (alist-ref 'content (extract-json-params! request))))
    (validate-param! content string?)
    (let* ((timestamp (utc-timestamp))
           (item (create-list! content timestamp)))
      (send-json (<list>->json item)))))

(define (process-get-list _request lid)
  (validate-param! lid db-id?)
  (let ((item (query-list (string->number lid))))
    (when (not item)
      (signal (http-error 'not-found '((err . "list not found")))))
    (send-json (<list>->json item))))

(define (process-delete-list! _request lid)
  (validate-param! lid db-id?)
  (with-exclusive-transaction (web-db)
    (lambda ()
      (let ((changes (delete-list! (string->number lid))))
        (cond
         ((not (integer? changes))
          (error "Unexpected DELETE FROM lists return value"))
         ((zero? changes)
          (send-json '((err . "list not found")) status: 'not-found)
          -1)
         (else
          (let ((timestamp (utc-timestamp)))
            (renumber-lists! (query-lists) timestamp))
          (send-response status: 'no-content)
          changes))))))

(define (process-update-list! request lid)
  (validate-param! lid db-id?)
  (let ((content (alist-ref 'content (extract-json-params! request))))
    (validate-param! content string?)
    (let* ((timestamp (utc-timestamp))
           (changes (update-list! (string->number lid) content timestamp)))
      (when (not (integer? changes))
        (error "Unexpected UPDATE lists SET return value"))
      (when (zero? changes)
        (signal (http-error 'not-found '((err . "list not found")))))
      (send-response status: 'no-content))))

(define (process-reorder-list! request lid)
  (validate-param! lid db-id?)
  (let ((to (alist-ref 'to (extract-json-params! request))))
    (validate-param! to integer?)
    (let* ((timestamp (utc-timestamp))
           (changes (reorder-list! (string->number lid) to timestamp)))
      (if (= changes -1)
          (send-json '((err . "list not found")) status: 'not-found)
          (send-response status: 'no-content)))))

;;; todo API

(define (process-get-todos _request lid)
  (validate-param! lid db-id?)
  (let ((items (query-todos (string->number lid))))
    (when (not (list? items))
      (signal (http-error 'not-found '((err . "list not found")))))
    (send-json
     (list->vector
      (map <todo>->json items)))))

(define (process-create-todo! request lid)
  (validate-param! lid db-id?)
  (let ((content (alist-ref 'content (extract-json-params! request))))
    (validate-param! content string?)
    (let* ((timestamp (utc-timestamp))
           (item (create-todo! lid content timestamp)))
      (when (not (<todo>? item))
        (signal (http-error 'not-found '((err . "list not found")))))
      (send-json (<todo>->json item)))))

(define (process-get-todo _request lid tid)
  (validate-param! lid db-id?)
  (validate-param! tid db-id?)
  (let ((item (query-todo (string->number lid) (string->number tid))))
    (when (not item)
      (signal (http-error 'not-found '((err . "list/todo not found")))))
    (send-json (<todo>->json item))))

(define (process-delete-todo! _request lid tid)
  (validate-param! lid db-id?)
  (validate-param! tid db-id?)
  (with-exclusive-transaction (web-db)
    (lambda ()
      (let ((changes (delete-todo! (string->number lid) (string->number tid))))
        (cond
         ((not (integer? changes))
          (error "Unexpected DELETE FROM todos return value"))
         ((zero? changes)
          (send-json '((err . "list/todo not found")) status: 'not-found)
          -1)
         (else
          (let ((timestamp (utc-timestamp)))
            (renumber-todos! (query-todos* lid) timestamp))
          (send-response status: 'no-content)
          changes))))))

(define (process-update-todo! request lid tid)
  (validate-param! lid db-id?)
  (validate-param! tid db-id?)
  (let ((content (alist-ref 'content (extract-json-params! request))))
    (validate-param! content string?)
    (let* ((timestamp (utc-timestamp))
           (changes (update-todo! (string->number lid) (string->number tid)
                                  content timestamp)))
      (when (not (integer? changes))
        (error "Unexpected UPDATE todos SET return value"))
      (when (zero? changes)
        (signal (http-error 'not-found '((err . "list/todo not found")))))
      (send-response status: 'no-content))))

(define (process-finish-todo! _request lid tid)
  (validate-param! lid db-id?)
  (validate-param! tid db-id?)
  (let* ((timestamp (utc-timestamp))
         (changes (finish-todo! (string->number lid) (string->number tid)
                                timestamp)))
    (when (not (integer? changes))
      (error "Unexpected UPDATE todos SET return value"))
    (when (zero? changes)
      (signal (http-error 'not-found '((err . "list/todo not found")))))
    (send-response status: 'no-content)))

(define (process-resurrect-todo! _request lid tid)
  (validate-param! lid db-id?)
  (validate-param! tid db-id?)
  (let* ((timestamp (utc-timestamp))
         (changes (resurrect-todo! (string->number lid) (string->number tid)
                                   timestamp)))
    (when (not (integer? changes))
      (error "Unexpected UPDATE todos SET return value"))
    (when (zero? changes)
      (signal (http-error 'not-found '((err . "list/todo not found")))))
    (send-response status: 'no-content)))

(define (process-reorder-todo! request lid tid)
  (validate-param! lid db-id?)
  (validate-param! tid db-id?)
  (let ((to (alist-ref 'to (extract-json-params! request))))
    (validate-param! to integer?)
    (let* ((timestamp (utc-timestamp))
           (changes (reorder-todo! (string->number lid) (string->number tid)
                                   to timestamp)))
      (if (= changes -1)
          (send-json '((err . "list/todo not found")) status: 'not-found)
          (send-response status: 'no-content)))))

;;; web entry point

(define (web-handler/maybe-extend-session handler-thunk)
  (let* ((request (current-request))
         (path (uri-path (request-uri request)))
         (authenticated? (request-authenticated? request)))
    ;; HACK: this is not entirely correct as even bogus API requests
    ;; extend the session duration (I don't see any obvious
    ;; vulnerability with that since the request still needs to be
    ;; authenticated)
    (match (list path authenticated?)
      (((or ('/ "api" . _)
            ('/ ""))
        #t)
       (and-let* ((session-id (current-session-id request)))
         (extend-session! session-id)))
      (_ #f)))
  (handler-thunk))

(define (web-handler/caching-headers handler-thunk)
  (let* ((request (current-request))
         (method (request-method request))
         (path (uri-path (request-uri request))))
    (match (list method path)
      (('GET (or ('/ "static" . _)
                 ('/ "favicon.ico")))
       ;; HACK: intarweb generates "No-Cache" with alist syntax, but
       ;; Firefox only recognizes lowercase "no-cache"...
       (with-headers '((cache-control . (#("no-cache" raw))))
         handler-thunk))
      ((_ _)
       (with-headers '((cache-control . (#("no-store" raw))))
         handler-thunk)))))

(define (web-handler/routes continue)
  (let* ((request (current-request))
         (method (request-method request))
         (path (uri-path (request-uri request)))
         (authenticated? (request-authenticated? request)))
    (condition-case
     (match (list method path authenticated?)
       ;; TODO: request to favicon.ico
       ;; NOTE: the default handler checks the request method for us
       (('GET ('/ "static" . args) _)
        ;; NOTE: normally, the default handler strips the root-path
        ;; prefix before serving the file, this trick undoes that
        (parameterize ((root-path "./"))
          (continue)))
       (('GET ('/ "logout") #t)
        (and-let* ((session-id (current-session-id request)))
          (and-let* ((session (query-session session-id)))
            (invalidate-session! session-id))
          (let ((cookie (generate-cookie-header session-id '((max-age . 0)))))
            (send-redirect "/login" cookie))))
       (('GET ('/ "logout") #f)
        (send-redirect "/login"))
       (('GET ('/ "login") _)
        (let ((status (if authenticated? 'ok 'unauthorized)))
          (send-html (login-page authenticated?) status: status)))
       (('POST ('/ "login") _)
        (process-login request))
       ((_ ('/ "api" . _) #f)
        (send-response status: 'forbidden))
       (('GET ('/ "") #t)
        (send-html (index-page)))

       (('GET ('/ "api" "lists") #t)
        (process-get-lists request))
       (('POST ('/ "api" "list") #t)
        (process-create-list! request))
       (('GET ('/ "api" "list" lid) #t)
        (process-get-list request lid))
       (('DELETE ('/ "api" "list" lid) #t)
        (process-delete-list! request lid))
       (('PUT ('/ "api" "list" lid) #t)
        (process-update-list! request lid))
       (('PUT ('/ "api" "list" lid "reorder") #t)
        (process-reorder-list! request lid))

       (('GET ('/ "api" "list" lid "todos") #t)
        (process-get-todos request lid))
       (('POST ('/ "api" "list" lid "todo") #t)
        (process-create-todo! request lid))
       (('GET ('/ "api" "list" lid "todo" tid) #t)
        (process-get-todo request lid tid))
       (('DELETE ('/ "api" "list" lid "todo" tid) #t)
        (process-delete-todo! request lid tid))
       (('PUT ('/ "api" "list" lid "todo" tid) #t)
        (process-update-todo! request lid tid))
       (('PUT ('/ "api" "list" lid "todo" tid "finish") #t)
        (process-finish-todo! request lid tid))
       (('PUT ('/ "api" "list" lid "todo" tid "resurrect") #t)
        (process-resurrect-todo! request lid tid))
       (('PUT ('/ "api" "list" lid "todo" tid "reorder") #t)
        (process-reorder-todo! request lid tid))

       (('GET _ #t)
        ;; NOTE: default handler serves 404 for us
        (continue))
       (('GET _ #f)
        (send-redirect "/login"))
       ((_ _ _)
        (send-response status: 'method-not-allowed)))
     (e (modo http)
        (let ((status (get-condition-property e 'modo 'status))
              (json (get-condition-property e 'modo 'json #f)))
          (if json
              (send-json json status: status)
              (send-response status: status)))))))

(define (web-handler continue)
  (web-handler/caching-headers
   (lambda ()
     (web-handler/maybe-extend-session
      (lambda ()
        (web-handler/routes continue))))))

(define (extend-exception-handler thunk)
  (let ((original-handler (current-exception-handler)))
    (lambda (exception)
      (thunk)
      (original-handler exception))))

(define (main web-port db-path)
  (trusted-proxies (list "localhost"))
  (vhost-map `((".*" . ,web-handler)))
  (root-path "static/")
  (server-bind-address "localhost")
  (server-port (string->number web-port))
  (set-buffering-mode! (current-output-port) #:line)
  (access-log (current-output-port))
  (web-db (open-database db-path))
  (on-exit close-db)
  (extend-exception-handler close-db)
  (setup-db)
  (printf "Listening on http://localhost:~a\n" web-port)
  (start-server))

(apply main (command-line-arguments))

)