safsaf/examples/blog-site/model.scm

(define-module (model)
  #:use-module (knots thread-pool)
  #:use-module (sqlite3)
  #:export (make-db
            call-with-db
            db-init!
            db-list-posts
            db-get-post
            db-create-post!
            db-update-post!
            db-delete-post!))

;;;
;;; Connection pool
;;;

(define* (make-db database-file #:key (pool-size 4))
  "Create a thread pool where each thread holds an open SQLite
connection to DATABASE-FILE."
  (make-fixed-size-thread-pool
   pool-size
   #:name "sqlite"
   #:thread-initializer
   (lambda ()
     (let ((db (sqlite-open database-file
                            (logior SQLITE_OPEN_READWRITE
                                    SQLITE_OPEN_CREATE))))
       (sqlite-busy-timeout db 5000)
       (sqlite-exec db "PRAGMA journal_mode=WAL")
       (sqlite-exec db "PRAGMA foreign_keys=ON")
       (list db)))
   #:thread-destructor
   (lambda (db)
     (sqlite-close db))))

(define (call-with-db pool proc)
  "Run (PROC db) on a thread from POOL, where DB is the thread's
SQLite connection.  Returns whatever PROC returns."
  (call-with-thread pool
    (lambda (db)
      (proc db))))

;;;
;;; Schema
;;;

(define (db-init! pool)
  "Create the schema if it doesn't exist."
  (call-with-db pool
    (lambda (db)
      (sqlite-exec db "
        CREATE TABLE IF NOT EXISTS posts (
          id INTEGER PRIMARY KEY AUTOINCREMENT,
          title TEXT NOT NULL,
          body TEXT NOT NULL,
          image_url TEXT,
          created_at TEXT NOT NULL DEFAULT (datetime('now'))
        )"))))

;;;
;;; Row conversions
;;;

(define (row->post-summary row)
  "Convert a list-view row (vector) to an alist."
  `((id         . ,(vector-ref row 0))
    (title      . ,(vector-ref row 1))
    (created-at . ,(vector-ref row 2))))

(define (row->post row)
  "Convert a detail-view row (vector) to an alist."
  `((id         . ,(vector-ref row 0))
    (title      . ,(vector-ref row 1))
    (body       . ,(vector-ref row 2))
    (image-url  . ,(vector-ref row 3))
    (created-at . ,(vector-ref row 4))))

;;;
;;; Queries
;;;

(define (db-list-posts pool)
  "Return all posts as a list of alists (id, title, created-at),
newest first."
  (call-with-db pool
    (lambda (db)
      (let ((stmt (sqlite-prepare db
                    "SELECT id, title, created_at FROM posts ORDER BY id DESC")))
        (let ((rows (sqlite-map row->post-summary stmt)))
          (sqlite-finalize stmt)
          rows)))))

(define (db-get-post pool id)
  "Return the post with ID as an alist, or #f if not found."
  (call-with-db pool
    (lambda (db)
      (let ((stmt (sqlite-prepare db
                    "SELECT id, title, body, image_url, created_at
                     FROM posts WHERE id = ?")))
        (sqlite-bind stmt 1 id)
        (let ((row (sqlite-step stmt)))
          (sqlite-finalize stmt)
          (and row (row->post row)))))))

(define (db-create-post! pool title body image-url)
  "Insert a new post and return its ID."
  (call-with-db pool
    (lambda (db)
      (let ((stmt (sqlite-prepare db
                    "INSERT INTO posts (title, body, image_url) VALUES (?, ?, ?)")))
        (sqlite-bind stmt 1 title)
        (sqlite-bind stmt 2 body)
        (sqlite-bind stmt 3 image-url)
        (sqlite-step stmt)
        (sqlite-finalize stmt)
        (let ((stmt (sqlite-prepare db "SELECT last_insert_rowid()")))
          (let ((row (sqlite-step stmt)))
            (sqlite-finalize stmt)
            (vector-ref row 0)))))))

(define (db-update-post! pool id title body image-url)
  "Update the post with ID.  Returns #t if a row was changed, #f otherwise."
  (call-with-db pool
    (lambda (db)
      (let ((stmt (sqlite-prepare db
                    "UPDATE posts SET title = ?, body = ?, image_url = ?
                     WHERE id = ?")))
        (sqlite-bind stmt 1 title)
        (sqlite-bind stmt 2 body)
        (sqlite-bind stmt 3 image-url)
        (sqlite-bind stmt 4 id)
        (sqlite-step stmt)
        (sqlite-finalize stmt)
        (> (sqlite-changes db) 0)))))

(define (db-delete-post! pool id)
  "Delete the post with ID.  Returns #t if a row was deleted, #f otherwise."
  (call-with-db pool
    (lambda (db)
      (let ((stmt (sqlite-prepare db "DELETE FROM posts WHERE id = ?")))
        (sqlite-bind stmt 1 id)
        (sqlite-step stmt)
        (sqlite-finalize stmt)
        (> (sqlite-changes db) 0)))))