Browse Source

scrobbler go brr

master
eta 7 months ago
commit
6db2076d68
  1. 3
      .gitignore
  2. 3
      deploy.sh
  3. 6
      deploy.txt
  4. 7
      schema.sql
  5. 172
      scrobble.lisp
  6. 104
      sqlite.lisp

3
.gitignore

@ -0,0 +1,3 @@
*.sqlite*
*.fasl
etascrobbler

3
deploy.sh

@ -0,0 +1,3 @@
#!/bin/sh
echo '*** NB: press Enter after the text stops scrolling past!'
sbcl < deploy.txt

6
deploy.txt

@ -0,0 +1,6 @@
(ql:quickload '(cl-who sqlite hunchentoot cl-json))
(load "sqlite.lisp")
(load "scrobble.lisp")
(sb-ext:save-lisp-and-die "./etascrobbler" :toplevel #'etascrobbler::main :executable t)

7
schema.sql

@ -0,0 +1,7 @@
CREATE TABLE plays (
id INTEGER PRIMARY KEY,
artist VARCHAR NOT NULL,
title VARCHAR NOT NULL,
additional_info VARCHAR,
ts INT NOT NULL
);

172
scrobble.lisp

@ -0,0 +1,172 @@
(defpackage :etascrobbler
(:use :cl))
(in-package :etascrobbler)
(setf (cl-who:html-mode) :html5)
(defvar *title* "etascrobbler")
;; Copied from TVL's panettone, with thanks to grfn
(defmacro render (() &body body)
`(who:with-html-output-to-string (*standard-output* nil :prologue t)
(:html
:lang "en"
(:head
(:title (who:esc *title*))
(:link :rel "stylesheet" :type "text/css" :href "//theta.eu.org/assets/webfonts/stylesheet.css")
(:link :rel "stylesheet" :type "text/css" :href "//theta.eu.org/css/main.css")
(:meta :name "viewport"
:content "width=device-width,initial-scale=1"))
(:header
:class "site-header"
(:div
:class "wrapper"
(:a
:class "site-title"
:href "/"
(:img
:src "//theta.eu.org/assets/img/logo.svg"
:alt "η")
" (eta)")
(:nav
:class "site-nav"
(:div
:class "trigger"
"etascrobbler"))))
(:div
:class "page-content"
(:div
:class "wrapper"
,@body)))))
(defun get-last-scrobble ()
(tq::with-prepared-statement
(get "SELECT artist, title, ts FROM plays ORDER by ts DESC LIMIT 1")
(when (sqlite:step-statement get)
(values-list (tq::column-values get)))))
(defun count-all-scrobbles ()
(tq::with-prepared-statement
(count "SELECT COUNT(*) FROM plays")
(sqlite:step-statement count)
(sqlite:statement-column-value count 0)))
(hunchentoot:define-easy-handler (validate-token :uri "/1/validate-token") ()
(setf (hunchentoot:content-type*) "application/json")
(cl-json:encode-json-to-string
'((:code . 200)
(:message . "token probably valid")
(:valid . t)
(:user . "eta"))))
(defun insert-play (artist title ts &optional additional-info)
(tq::with-prepared-statement
(insert "INSERT INTO plays (artist, title, additional_info, ts) VALUES (?, ?, ?, ?)")
(tq::bind-parameters insert artist title additional-info ts)
(sqlite:step-statement insert)))
(defun get-all-artists ()
(tq::with-prepared-statement
(get "SELECT DISTINCT artist FROM plays ORDER BY artist ASC")
(loop
while (sqlite:step-statement get)
collect (sqlite:statement-column-value get 0))))
(defmacro cassoc (item alist)
`(cdr (assoc ,item ,alist)))
(defparameter *ok* "{\"status\": \"ok\"}")
(defvar *nowplaying* nil)
(defvar *nowplaying-ts* 0)
(hunchentoot:define-easy-handler (now-playing :uri "/now-playing.json") ()
(unless *nowplaying*
(setf (hunchentoot:return-code*) hunchentoot:+http-not-found+)
(return-from now-playing "nope"))
(setf (hunchentoot:content-type*) "application/json")
(cl-json:encode-json-to-string
`((:artist . ,(car *nowplaying*))
(:track . ,(cdr *nowplaying*))
(:since . ,(- (get-universal-time) *nowplaying-ts*)))))
(hunchentoot:define-easy-handler (submit-listens :uri "/1/submit-listens") ()
(labels
((fail (e)
(setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)
(format *error-output* "womp: ~A~%" e)
(return-from submit-listens e)))
(let* ((json
(handler-case
(cl-json:decode-json-from-string
(hunchentoot:raw-post-data :force-text t))
(error (e) (fail (format nil "bad: ~A" e)))))
(payload (or (first (cassoc :payload json))
(fail "no payload provided")))
(track-meta (or (cassoc :track--metadata payload)
(fail "no track metadata provided")))
(artist-name (cassoc :artist--name track-meta))
(track-name (cassoc :track--name track-meta))
(listen-type (cassoc :listen--type json)))
(setf (hunchentoot:content-type*) "application/json")
(format *error-output* "~&[~A] ~A — ~A~%" listen-type artist-name track-name)
(when (string= listen-type "playing_now")
(setf *nowplaying-ts* (get-universal-time))
(setf *nowplaying* (cons artist-name track-name)))
(unless (string= listen-type "single")
(return-from submit-listens *ok*))
(insert-play
(cassoc :artist--name track-meta)
(cassoc :track--name track-meta)
(cassoc :listened--at payload)
(prin1-to-string (cassoc :additional--info track-meta)))
*ok*)))
(hunchentoot:define-easy-handler (root :uri "/") ()
(render ()
(:h1
"now playing")
(:p
"This shows what I was last listening to on any of my devices, and the song before that. "
"This tiny webapp has observed "
(:b
(who:esc (princ-to-string (count-all-scrobbles))))
" songs being played so far.")
(:p
"This site is very beta. More information should be added shortly!")
(when *nowplaying*
(who:with-html-output (*standard-output*)
(:div
:class "book-meta"
(:p
:class "book-title"
"🎵 "
(who:esc (car *nowplaying*))
" — "
(who:esc (cdr *nowplaying*))))))
(multiple-value-bind (artist title)
(get-last-scrobble)
(when artist
(who:with-html-output (*standard-output*)
(:p
(:i
"Previously: ")
(who:esc artist)
" — "
(who:esc title)))))
(let ((artists (get-all-artists)))
(who:with-html-output (*standard-output*)
(:p
:class "detail"
"Artists ("
(:strong
(who:esc (princ-to-string (length artists))))
"): "
(who:esc (format nil "~{~A~^ · ~}" artists)))))))
(defun main ()
(tq::connect-database)
(hunchentoot:start
(make-instance 'hunchentoot:easy-acceptor
:port 4242))
(sb-impl::toplevel-repl nil))

104
sqlite.lisp

@ -0,0 +1,104 @@
;;;; eta's standard SQLite wrapper, which has about 4 copies in various
;;;; Lisp libraries and programs
;;;;
;;;; It'll totally get factored out one of these days!
(defpackage :theqlite
(:nicknames :tq)
(:use :cl))
(in-package :theqlite)
(defvar *db* nil
"Connection to the database.")
(defvar *db-lock* (bt:make-recursive-lock "sqlite3 lock")
"Lock for *DB*.")
(defparameter *default-database-path* "data.sqlite3"
"Default path to the SQLite database file.")
(defvar *prepared-statements* nil
"List of statements prepared by PREPARED-STATEMENT.")
(defparameter *sqlite-pragmas*
'("PRAGMA journal_mode = WAL"
"PRAGMA foreign_keys = ON"
"PRAGMA synchronous = NORMAL")
"List of SQLite pragmas to run on connection to make things bearable")
(defun run-pragmas ()
"Runs all statements in *SQLITE-PRAGMAS*."
(mapc (lambda (x) (sqlite:execute-non-query *db* x)) *sqlite-pragmas*))
(defun connect-database (&optional (path *default-database-path*))
"Establish a connection to the database."
(bt:with-recursive-lock-held (*db-lock*)
(setf *db* (sqlite:connect path))
(run-pragmas)
(loop for sym in *prepared-statements*
do (eval `(setf ,sym nil)))
(setf *prepared-statements* nil)))
(defmacro with-transaction (&body forms)
`(bt:with-recursive-lock-held (*db-lock*)
(sqlite:with-transaction *db*
,@forms)))
(defmacro prepared-statement (statement)
"Caches the creation of a prepared statement with SQL text STATEMENT.
In other words, prepares STATEMENT once, then returns the prepared statement after that instead of doing that work again."
(let ((statement-sym (gensym "PREPARED-STATEMENT-")))
(eval `(defvar ,statement-sym nil))
`(progn
(defvar ,statement-sym nil)
(unless ,statement-sym
(setf ,statement-sym (sqlite:prepare-statement *db* ,statement))
(setf *prepared-statements* (cons ',statement-sym *prepared-statements*)))
,statement-sym)))
(defmacro with-prepared-statement ((name statement) &body forms)
"Evaluates FORMS, binding a prepared statement with SQL text STATEMENT to NAME and making sure it is reset beforehand."
`(bt:with-recursive-lock-held (*db-lock*)
(let ((,name (prepared-statement ,statement)))
(sqlite:reset-statement ,name)
(sqlite:clear-statement-bindings ,name)
,@forms)))
(defmacro with-prepared-statements (statements &body forms)
"Like WITH-PREPARED-STATEMENT, but takes multiple statements."
(let ((let-forms (loop for (name statement) in statements
collect `(,name (prepared-statement ,statement))))
(reset-forms (loop for (name statement) in statements
collect `(progn
(sqlite:reset-statement ,name)
(sqlite:clear-statement-bindings ,name)))))
`(bt:with-recursive-lock-held (*db-lock*)
(let (,@let-forms)
,@reset-forms
,@forms))))
(defmacro column-values (statement)
"Returns the values in the current row of the STATEMENT."
(let ((i-sym (gensym))
(stmt (gensym)))
`(let ((,stmt ,statement))
(loop
for ,i-sym from 0 below (length (sqlite:statement-column-names ,stmt))
collect (sqlite:statement-column-value ,stmt ,i-sym)))))
(defmacro with-bound-columns (parameters statement &body forms)
"Binds each column value of STATEMENT to the symbols in PARAMETERS, and runs FORMS."
(let ((let-forms (loop
for param in parameters
for idx from 0 upto (1- (length parameters))
collect `(,param (sqlite:statement-column-value ,statement ,idx)))))
`(let (,@let-forms) ,@forms)))
(defmacro bind-parameters (statement &rest parameters)
"Binds PARAMETERS to the prepared statement STATEMENT.
PARAMETERS are either simple values (in which case they're bound to parameters 1, 2, ...),
or cons cells, where the `car` is the index to bind to and the `cdr' is the value to use."
`(progn
,@(loop for param in parameters
for idx from 1 upto (length parameters)
collect (if (listp param)
`(sqlite:bind-parameter ,statement ,(car param) ,(second param))
`(sqlite:bind-parameter ,statement ,idx ,param)))))
Loading…
Cancel
Save