commit 346b4d5fc7425664c82be8e496dfafb4d9437cdc
parent a7f4e30a632ad9a176b57fbfe42e603fc900dd32
Author: mtmn <miro@haravara.org>
Date: Sun, 19 Apr 2026 20:07:25 +0200
feat: add about, labels and fix search
Diffstat:
8 files changed, 159 insertions(+), 52 deletions(-)
diff --git a/src/Client.elm b/src/Client.elm
@@ -19,10 +19,16 @@ import Url
port pushUrl : String -> Cmd msg
+type alias UserInfo =
+ { slug : String
+ , name : String
+ }
+
+
type alias Flags =
{ search : String
, userSlug : String
- , allUsers : List String
+ , allUsers : List UserInfo
}
@@ -64,6 +70,7 @@ type alias Listen =
, releaseName : Maybe String
, listenedAt : Maybe Int
, genre : Maybe String
+ , label : Maybe String
, releaseMbid : Maybe String
, caaReleaseMbid : Maybe String
}
@@ -122,7 +129,7 @@ type alias Model =
, customError : Maybe String
, userSlug : String
, similarStates : Dict String SimilarState
- , allUsers : List String
+ , allUsers : List UserInfo
, searchInput : String
, activeSearch : Maybe String
}
@@ -639,6 +646,7 @@ listenDecoder =
, releaseName = meta.releaseName
, listenedAt = listenedAt
, genre = meta.genre
+ , label = meta.label
, releaseMbid = meta.releaseMbid
, caaReleaseMbid = meta.caaReleaseMbid
}
@@ -654,18 +662,20 @@ type alias TrackMeta =
, genre : Maybe String
, releaseMbid : Maybe String
, caaReleaseMbid : Maybe String
+ , label : Maybe String
}
trackMetaDecoder : Decoder TrackMeta
trackMetaDecoder =
- D.map6 TrackMeta
+ D.map7 TrackMeta
(D.maybe (D.field "track_name" D.string))
(D.maybe (D.field "artist_name" D.string))
(D.maybe (D.field "release_name" D.string))
(D.maybe (D.field "genre" D.string))
(D.maybe (D.at [ "mbid_mapping", "release_mbid" ] D.string))
(D.maybe (D.at [ "mbid_mapping", "caa_release_mbid" ] D.string))
+ (D.maybe (D.field "label" D.string))
statsDecoder : Decoder Stats
@@ -929,14 +939,23 @@ renderListen userSlug currentTime failedCovers hoveredCover similarStates idx li
, div [ class "track-artist" ] [ text artist ]
, div [ class "track-time" ]
[ span []
- [ a
+ (a
[ href ("https://www.discogs.com/search/?q=" ++ Url.percentEncode (artist ++ " " ++ release) ++ "&type=release")
, target "_blank"
, class "album-link"
]
[ text release ]
- , text (" • " ++ timeAgo currentTime listen.listenedAt)
- ]
+ :: (case listen.label of
+ Just l ->
+ [ text " • "
+ , button [ class "label-link", onClick (FilterBy "label" l) ] [ text l ]
+ ]
+
+ Nothing ->
+ []
+ )
+ ++ [ text (" • " ++ timeAgo currentTime listen.listenedAt) ]
+ )
]
]
, div [ class "cover-wrapper" ]
@@ -1265,7 +1284,6 @@ renderPeriodSelector current showInput customVal mError =
]
-
onEnter : msg -> Html.Attribute msg
onEnter msg =
on "keydown"
@@ -1348,13 +1366,13 @@ timeAgo mNow mTimestamp =
"unknown time"
-renderAboutView : String -> List String -> Html Msg
+renderAboutView : String -> List UserInfo -> Html Msg
renderAboutView currentSlug allUsers =
let
otherUsers =
- List.filter (\s -> s /= currentSlug) allUsers
+ List.filter (\u -> u.slug /= currentSlug) allUsers
- userLink slug =
+ userLink { slug, name } =
let
url =
if slug == "" then
@@ -1362,25 +1380,41 @@ renderAboutView currentSlug allUsers =
else
"/u/" ++ slug
-
- label =
- if slug == "" then
- "root"
-
- else
- slug
in
- li [] [ a [ href url ] [ text label ] ]
+ li [] [ a [ href url ] [ text name ] ]
+
+ extLink url label =
+ a [ href url, target "_blank", class "about-link" ] [ text label ]
in
div []
- [ p [ class "about-description" ]
- [ text "corpus is a self-hosted music scrobble viewer. it aggregates listening history from ListenBrainz and Last.fm, enriches tracks with metadata from MusicBrainz, and provides browsable listen history and statistics." ]
+ [ p [ class "about-lead" ]
+ [ text "corpus is a self-hosted listen history proxy that syncs scrobbles from "
+ , extLink "https://listenbrainz.org" "ListenBrainz"
+ , text " and "
+ , extLink "https://www.last.fm" "Last.fm."
+ ]
+ , div [ class "stats-section" ]
+ [ h2 [] [ text "features" ]
+ , ul [ class "about-list" ]
+ [ li [] [ text "searchable listen history with pagination" ]
+ , li [] [ text "stats by artist, track, label, year, and genre" ]
+ , li [] [ text "filter listens by label, artist, genre, or year" ]
+ , li [] [ text "cover art from Cover Art Archive, Last.fm, and Discogs" ]
+ , li [] [ text "similar track discovery via cosine.club" ]
+ , li [] [ text "metadata enrichment via MusicBrainz, Last.fm, and Discogs" ]
+ ]
+ ]
+ , div [ class "stats-section" ]
+ [ h2 [] [ text "source" ]
+ , p [ class "about-meta" ]
+ [ extLink "https://codeberg.org/mtmn/corpus" "codeberg.org/mtmn/corpus" ]
+ ]
, if List.isEmpty otherUsers then
text ""
else
div [ class "stats-section" ]
- [ h2 [] [ text "users" ]
+ [ h2 [] [ text "friends" ]
, ul [ class "about-users" ]
(List.map userLink otherUsers)
]
diff --git a/src/Config.purs b/src/Config.purs
@@ -37,6 +37,7 @@ type UserConfig =
type UserEntry =
{ slug :: String
+ , name :: Maybe String
, config :: UserConfig
}
@@ -157,9 +158,10 @@ decodeUserEntry :: Json -> Either String UserEntry
decodeUserEntry json = do
obj <- mapLeft show $ decodeJson json
slug <- mapLeft show $ obj .: "slug"
+ name <- mapLeft show $ obj .:? "name"
configJson <- mapLeft show (obj .: "config" :: Either _ Json)
config <- decodeUserConfig configJson
- pure { slug, config }
+ pure { slug, name, config }
-- Decodes only the non-sensitive, per-user fields from users.json.
-- Shared credentials are injected from environment variables in loadConfig.
diff --git a/src/Db.purs b/src/Db.purs
@@ -177,20 +177,31 @@ upsertScrobble conn (Listen { listenedAt, trackMetadata: TrackMetadata track })
]
run conn "INSERT INTO scrobbles SELECT * FROM (SELECT ? as listened_at, ? as track_name, ? as artist_name, ? as release_name, ? as release_mbid, ? as caa_release_mbid) t WHERE NOT EXISTS (SELECT 1 FROM scrobbles WHERE listened_at = t.listened_at)" params
+scrobbleCols :: String
+scrobbleCols = "SELECT s.listened_at, s.track_name, s.artist_name, s.release_name, s.release_mbid, s.caa_release_mbid, rm.genre, rm.label"
+
+scrobbleFromLeft :: String
+scrobbleFromLeft = " FROM scrobbles s LEFT JOIN release_metadata rm ON s.release_mbid = rm.release_mbid"
+
+scrobbleFromInner :: String
+scrobbleFromInner = " FROM scrobbles s JOIN release_metadata rm ON s.release_mbid = rm.release_mbid"
+
+scrobbleOrderPage :: String
+scrobbleOrderPage = " ORDER BY s.listened_at DESC LIMIT ? OFFSET ?"
+
getScrobbles :: Connection -> Int -> Int -> Maybe { field :: FilterField, value :: String } -> Maybe String -> Aff (Array Listen)
getScrobbles conn limit offset _ (Just q) = do
let pattern = "%" <> q <> "%"
rows <- queryAll conn
- ( "SELECT s.listened_at, s.track_name, s.artist_name, s.release_name, s.release_mbid, s.caa_release_mbid, rm.genre"
- <> " FROM scrobbles s LEFT JOIN release_metadata rm ON s.release_mbid = rm.release_mbid"
+ ( scrobbleCols <> scrobbleFromLeft
<> " WHERE (s.track_name ILIKE ? OR s.artist_name ILIKE ? OR s.release_name ILIKE ? OR rm.label ILIKE ?)"
- <> " ORDER BY s.listened_at DESC LIMIT ? OFFSET ?"
+ <> scrobbleOrderPage
)
[ unsafeCoerce pattern, unsafeCoerce pattern, unsafeCoerce pattern, unsafeCoerce pattern, unsafeCoerce limit, unsafeCoerce offset ]
pure $ mapMaybe rowToListen rows
getScrobbles conn limit offset Nothing Nothing = do
rows <- queryAll conn
- "SELECT s.listened_at, s.track_name, s.artist_name, s.release_name, s.release_mbid, s.caa_release_mbid, rm.genre FROM scrobbles s LEFT JOIN release_metadata rm ON s.release_mbid = rm.release_mbid ORDER BY s.listened_at DESC LIMIT ? OFFSET ?"
+ (scrobbleCols <> scrobbleFromLeft <> scrobbleOrderPage)
[ unsafeCoerce limit, unsafeCoerce offset ]
pure $ mapMaybe rowToListen rows
getScrobbles conn limit offset (Just { field, value }) Nothing = do
@@ -199,21 +210,17 @@ getScrobbles conn limit offset (Just { field, value }) Nothing = do
filterQuery :: FilterField -> String
filterQuery FilterArtist =
- "SELECT s.listened_at, s.track_name, s.artist_name, s.release_name, s.release_mbid, s.caa_release_mbid, rm.genre"
- <> " FROM scrobbles s LEFT JOIN release_metadata rm ON s.release_mbid = rm.release_mbid"
- <> " WHERE s.artist_name = ? ORDER BY s.listened_at DESC LIMIT ? OFFSET ?"
+ scrobbleCols <> scrobbleFromLeft
+ <> " WHERE s.artist_name = ?" <> scrobbleOrderPage
filterQuery FilterLabel =
- "SELECT s.listened_at, s.track_name, s.artist_name, s.release_name, s.release_mbid, s.caa_release_mbid, rm.genre"
- <> " FROM scrobbles s JOIN release_metadata rm ON s.release_mbid = rm.release_mbid"
- <> " WHERE rm.label = ? ORDER BY s.listened_at DESC LIMIT ? OFFSET ?"
+ scrobbleCols <> scrobbleFromInner
+ <> " WHERE rm.label = ?" <> scrobbleOrderPage
filterQuery FilterYear =
- "SELECT s.listened_at, s.track_name, s.artist_name, s.release_name, s.release_mbid, s.caa_release_mbid, rm.genre"
- <> " FROM scrobbles s JOIN release_metadata rm ON s.release_mbid = rm.release_mbid"
- <> " WHERE rm.release_year::VARCHAR = ? ORDER BY s.listened_at DESC LIMIT ? OFFSET ?"
+ scrobbleCols <> scrobbleFromInner
+ <> " WHERE rm.release_year::VARCHAR = ?" <> scrobbleOrderPage
filterQuery FilterGenre =
- "SELECT s.listened_at, s.track_name, s.artist_name, s.release_name, s.release_mbid, s.caa_release_mbid, rm.genre"
- <> " FROM scrobbles s JOIN release_metadata rm ON s.release_mbid = rm.release_mbid"
- <> " WHERE rm.genre = ? ORDER BY s.listened_at DESC LIMIT ? OFFSET ?"
+ scrobbleCols <> scrobbleFromInner
+ <> " WHERE rm.genre = ?" <> scrobbleOrderPage
initReleaseMetadata :: Connection -> Aff Unit
initReleaseMetadata conn = do
@@ -333,6 +340,7 @@ rowToListen json = do
releaseMbid <- Object.lookup "release_mbid" obj >>= toString
caaReleaseMbid <- Object.lookup "caa_release_mbid" obj >>= toString
let genre = Object.lookup "genre" obj >>= toString
+ let label = Object.lookup "label" obj >>= toString
pure $ Listen
{ listenedAt: Just listenedAt
@@ -341,6 +349,7 @@ rowToListen json = do
, artistName: Just artistName
, releaseName: Just releaseName
, genre
+ , label
, mbidMapping: Just $ MbidMapping
{ releaseMbid: if releaseMbid == "" then Nothing else Just releaseMbid
, caaReleaseMbid: if caaReleaseMbid == "" then Nothing else Just caaReleaseMbid
diff --git a/src/Main.purs b/src/Main.purs
@@ -67,6 +67,7 @@ type UserContext =
, writeLock :: AVar Unit
, config :: UserConfig
, slug :: String
+ , displayName :: String
}
listenBrainzUrl :: String -> String
@@ -157,6 +158,7 @@ lastfmTrackToListen json = do
, artistName: Just artistName
, releaseName: releaseName
, genre: Nothing
+ , label: Nothing
, mbidMapping: Just $ MbidMapping
{ releaseMbid: releaseMbid
, caaReleaseMbid: releaseMbid
@@ -332,7 +334,7 @@ handleRequest :: Boolean -> Array UserContext -> Request -> Response -> Effect U
handleRequest metricsEnabled contexts req res = do
let method = IM.method req
let rawUrl = IM.url req
- let allSlugs = map _.slug contexts
+ let allUsers = map (\ctx -> { slug: ctx.slug, name: ctx.displayName }) contexts
case URL.fromRelative rawUrl "http://localhost" of
Nothing ->
serveNotFound res
@@ -345,7 +347,7 @@ handleRequest metricsEnabled contexts req res = do
"/favicon.png" ->
serveAsset "image/png" "assets/favicon.png" res
"/" ->
- serveIndex allSlugs "" res
+ serveIndex allUsers "" res
"/metrics" ->
if metricsEnabled then serveMetrics res
else do
@@ -364,7 +366,7 @@ handleRequest metricsEnabled contexts req res = do
_ ->
case stripPrefix (Pattern "/u/") path of
Just slug ->
- serveIndex allSlugs slug res
+ serveIndex allUsers slug res
Nothing -> do
Log.warn $ "Path not found: " <> path
serveNotFound res
@@ -380,12 +382,12 @@ handleRequest metricsEnabled contexts req res = do
Just ctx ->
f ctx
-serveIndex :: Array String -> String -> Response -> Effect Unit
-serveIndex allSlugs slug res = do
+serveIndex :: Array { slug :: String, name :: String } -> String -> Response -> Effect Unit
+serveIndex allUsers slug res = do
setHeader "Content-Type" "text/html" (toOutgoingMessage res)
setStatusCode 200 res
let w = toWriteable (toOutgoingMessage res)
- void $ writeString w UTF8 (indexHtml slug allSlugs)
+ void $ writeString w UTF8 (indexHtml slug allUsers)
end w
serveMetrics :: Response -> Effect Unit
@@ -946,7 +948,7 @@ enrichMetadata conn cfg slug = forever do
-- Initialise one user: connect DB, start sync loops, return a UserContext.
startUser :: UserEntry -> Aff UserContext
-startUser { slug, config } = do
+startUser { slug, name, config } = do
Log.info $ "Starting user: " <> if slug == "" then "(root)" else slug
conn <- connect config.databaseFile
initDb conn
@@ -984,7 +986,8 @@ startUser { slug, config } = do
(toNumber config.backupIntervalHours * 3600000.0)
slug
- pure { conn, writeLock, config, slug }
+ let displayName = fromMaybe (if slug == "" then "root" else slug) name
+ pure { conn, writeLock, config, slug, displayName }
foreign import dotenvConfig :: Effect Unit
diff --git a/src/Templates.purs b/src/Templates.purs
@@ -3,10 +3,11 @@ module Templates where
import Prelude
import Data.String.Common (joinWith)
-indexHtml :: String -> Array String -> String
+indexHtml :: String -> Array { slug :: String, name :: String } -> String
indexHtml userSlug allUsers =
let
- usersJson = "[" <> joinWith "," (map (\s -> "\"" <> s <> "\"") allUsers) <> "]"
+ encodeUser { slug, name } = "{\"slug\":\"" <> slug <> "\",\"name\":\"" <> name <> "\"}"
+ usersJson = "[" <> joinWith "," (map encodeUser allUsers) <> "]"
in
"""<!DOCTYPE html>
<html lang="en">
@@ -101,6 +102,21 @@ indexHtml userSlug allUsers =
color: #ffffff;
}
+ .label-link {
+ background: none;
+ border: none;
+ padding: 0;
+ color: #9fbfe7;
+ text-decoration: underline;
+ font-family: inherit;
+ font-size: inherit;
+ cursor: pointer;
+ }
+
+ .label-link:hover {
+ color: #ffffff;
+ }
+
.track-cover {
width: 60px;
height: 60px;
@@ -612,11 +628,48 @@ indexHtml userSlug allUsers =
border-color: #6a5fa0;
}
- .about-description {
+ .about-lead {
color: #a0c0d0;
font-size: 13px;
line-height: 1.8;
- margin: 0 0 24px 0;
+ margin: 0 0 30px 0;
+ }
+
+ .about-link {
+ color: #9fbfe7;
+ text-decoration: underline;
+ }
+
+ .about-link:hover {
+ color: #ffffff;
+ }
+
+ .about-list {
+ list-style: none;
+ padding: 0;
+ margin: 0;
+ }
+
+ .about-list li {
+ background: none;
+ border: none;
+ border-radius: 0;
+ padding: 3px 0;
+ margin-bottom: 0;
+ display: block;
+ box-shadow: none;
+ font-size: 13px;
+ color: #a0c0d0;
+ }
+
+ .about-list li::before {
+ content: "→ ";
+ color: #50447f;
+ }
+
+ .about-meta {
+ font-size: 13px;
+ margin: 0;
}
.about-users {
diff --git a/src/Types.purs b/src/Types.purs
@@ -77,6 +77,7 @@ newtype TrackMetadata = TrackMetadata
, releaseName :: Maybe String
, mbidMapping :: Maybe MbidMapping
, genre :: Maybe String
+ , label :: Maybe String
}
derive instance eqTrackMetadata :: Eq TrackMetadata
@@ -92,15 +93,17 @@ instance DecodeJson TrackMetadata where
releaseName <- obj .:? "release_name"
mbidMapping <- obj .:? "mbid_mapping"
genre <- obj .:? "genre"
- pure $ TrackMetadata { trackName, artistName, releaseName, mbidMapping, genre }
+ label <- obj .:? "label"
+ pure $ TrackMetadata { trackName, artistName, releaseName, mbidMapping, genre, label }
instance EncodeJson TrackMetadata where
- encodeJson (TrackMetadata { trackName, artistName, releaseName, mbidMapping, genre }) =
+ encodeJson (TrackMetadata { trackName, artistName, releaseName, mbidMapping, genre, label }) =
"track_name" := encodeJson trackName
~> "artist_name" := encodeJson artistName
~> "release_name" := encodeJson releaseName
~> "mbid_mapping" := encodeJson mbidMapping
~> "genre" := encodeJson genre
+ ~> "label" := encodeJson label
~> jsonEmptyObject
newtype MbidMapping = MbidMapping
diff --git a/users.dhall b/users.dhall
@@ -21,6 +21,7 @@ let defaults
in { users =
[ { slug = ""
+ , name = Some "mtmn"
, config =
defaults
with listenbrainzUser = Some "mtmn"
@@ -28,6 +29,7 @@ in { users =
with backupEnabled = True
}
, { slug = "mtmnn"
+ , name = None Text
, config =
defaults
with lastfmUser = Some "mtmnn"
diff --git a/users.json b/users.json
@@ -9,6 +9,7 @@
"initialSync": false,
"listenbrainzUser": "mtmn"
},
+ "name": "mtmn",
"slug": ""
},
{
