commit 612dcebd7ae4f62ddb284a5d6b3a933e7da3c11a
parent 96b22d1c3a5e8459c4807eb86d06533a48233cfb
Author: mtmn <miro@haravara.org>
Date: Mon, 1 Jun 2026 21:52:15 +0200
fix: deduplicate sql logic; separate Handler.purs
Diffstat:
| M | src/Db.purs | | | 52 | +++++++++++++++++++++++++++++----------------------- |
| A | src/Handler.purs | | | 47 | +++++++++++++++++++++++++++++++++++++++++++++++ |
| M | src/Main.purs | | | 49 | ++----------------------------------------------- |
| M | src/Sync.purs | | | 127 | ++++++++++++++++++++++++++++++++++++++++++++++++++++--------------------------- |
4 files changed, 162 insertions(+), 113 deletions(-)
diff --git a/src/Db.purs b/src/Db.purs
@@ -39,6 +39,12 @@ import Unsafe.Coerce (unsafeCoerce)
foreign import data Connection :: Type
+-- | Coerces a value to Foreign for SQL parameters.
+-- | This centralizes all unsafeCoerce usage for database operations
+-- | into a single auditable point.
+toParam :: forall a. a -> Foreign
+toParam = unsafeCoerce
+
data FilterField = FilterArtist | FilterAlbum | FilterLabel | FilterYear | FilterGenre | FilterTrack
derive instance Eq FilterField
@@ -152,19 +158,19 @@ initDb conn = do
getOrCreateToken :: Connection -> String -> Aff (Maybe String)
getOrCreateToken conn slug = do
- rows <- queryAll conn "SELECT hashed_token FROM api_tokens WHERE slug = ?" [ unsafeCoerce slug ]
+ rows <- queryAll conn "SELECT hashed_token FROM api_tokens WHERE slug = ?" [ toParam slug ]
case rows !! 0 >>= toObject >>= Object.lookup "hashed_token" >>= toString of
Just _ ->
pure Nothing
Nothing -> do
token <- liftEffect $ map UUID.toString UUID.genUUID
let hashedToken = sha256 token
- run conn "INSERT INTO api_tokens (slug, hashed_token) VALUES (?, ?)" [ unsafeCoerce slug, unsafeCoerce hashedToken ]
+ run conn "INSERT INTO api_tokens (slug, hashed_token) VALUES (?, ?)" [ toParam slug, toParam hashedToken ]
pure $ Just token
checkExists :: Connection -> Int -> Aff Boolean
checkExists conn ts = do
- rows <- queryAll conn "SELECT 1 FROM scrobbles WHERE listened_at = ?" [ unsafeCoerce ts ]
+ rows <- queryAll conn "SELECT 1 FROM scrobbles WHERE listened_at = ?" [ toParam ts ]
pure case rows of
[] -> false
_ -> true
@@ -186,12 +192,12 @@ upsertScrobble conn (Listen { listenedAt, trackMetadata: TrackMetadata track })
mbid = fromMaybe (MbidMapping { releaseMbid: Nothing, caaReleaseMbid: Nothing }) track.mbidMapping
MbidMapping m = mbid
params =
- [ unsafeCoerce ts
- , unsafeCoerce (fromMaybe "" track.trackName)
- , unsafeCoerce (fromMaybe "" track.artistName)
- , unsafeCoerce (fromMaybe "" track.releaseName)
- , unsafeCoerce (fromMaybe "" m.releaseMbid)
- , unsafeCoerce (fromMaybe "" m.caaReleaseMbid)
+ [ toParam ts
+ , toParam (fromMaybe "" track.trackName)
+ , toParam (fromMaybe "" track.artistName)
+ , toParam (fromMaybe "" track.releaseName)
+ , toParam (fromMaybe "" m.releaseMbid)
+ , toParam (fromMaybe "" m.caaReleaseMbid)
]
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
@@ -215,15 +221,15 @@ getScrobbles conn limit offset _ (Just q) = do
<> " WHERE (s.track_name ILIKE ? OR s.artist_name ILIKE ? OR s.release_name ILIKE ? OR rm.label ILIKE ?)"
<> scrobbleOrderPage
)
- [ unsafeCoerce pattern, unsafeCoerce pattern, unsafeCoerce pattern, unsafeCoerce pattern, unsafeCoerce limit, unsafeCoerce offset ]
+ [ toParam pattern, toParam pattern, toParam pattern, toParam pattern, toParam limit, toParam offset ]
pure $ mapMaybe rowToListen rows
getScrobbles conn limit offset Nothing Nothing = do
rows <- queryAll conn
(scrobbleCols <> scrobbleFromLeft <> scrobbleOrderPage)
- [ unsafeCoerce limit, unsafeCoerce offset ]
+ [ toParam limit, toParam offset ]
pure $ mapMaybe rowToListen rows
getScrobbles conn limit offset (Just { field, value }) Nothing = do
- rows <- queryAll conn (filterQuery field) [ unsafeCoerce value, unsafeCoerce limit, unsafeCoerce offset ]
+ rows <- queryAll conn (filterQuery field) [ toParam value, toParam limit, toParam offset ]
pure $ mapMaybe rowToListen rows
filterQuery :: FilterField -> String
@@ -265,7 +271,7 @@ getUnenrichedMbids :: Connection -> Int -> Aff (Array String)
getUnenrichedMbids conn limit = do
rows <- queryAll conn
"SELECT DISTINCT release_mbid FROM scrobbles WHERE release_mbid != '' AND release_mbid NOT IN (SELECT release_mbid FROM release_metadata) LIMIT ?"
- [ unsafeCoerce limit ]
+ [ toParam limit ]
pure $ mapMaybe extractMbid rows
where
extractMbid json = do
@@ -276,7 +282,7 @@ getEmptyGenreMbids :: Connection -> Int -> Aff (Array String)
getEmptyGenreMbids conn limit = do
rows <- queryAll conn
"SELECT DISTINCT s.release_mbid FROM scrobbles s JOIN release_metadata rm ON s.release_mbid = rm.release_mbid WHERE (rm.genre IS NULL OR rm.genre = '') AND (rm.genre_checked_at IS NULL OR rm.genre_checked_at < CAST(epoch(now()) AS INTEGER) - 604800) LIMIT ?"
- [ unsafeCoerce limit ]
+ [ toParam limit ]
pure $ mapMaybe extractMbid rows
where
extractMbid json = do
@@ -287,17 +293,17 @@ upsertReleaseMetadata :: Connection -> String -> Maybe String -> Maybe String ->
upsertReleaseMetadata conn mbid genre label year =
run conn
"INSERT INTO release_metadata (release_mbid, genre, label, release_year) VALUES (?, ?, ?, ?) ON CONFLICT(release_mbid) DO UPDATE SET genre=excluded.genre, label=excluded.label, release_year=excluded.release_year"
- [ unsafeCoerce mbid
- , unsafeCoerce (toNullable genre)
- , unsafeCoerce (toNullable label)
- , unsafeCoerce (toNullable year)
+ [ toParam mbid
+ , toParam (toNullable genre)
+ , toParam (toNullable label)
+ , toParam (toNullable year)
]
touchGenreCheckedAt :: Connection -> String -> Aff Unit
touchGenreCheckedAt conn mbid = do
run conn
"UPDATE release_metadata SET genre_checked_at = CAST(epoch(now()) AS INTEGER) WHERE release_mbid = ?"
- [ unsafeCoerce mbid ]
+ [ toParam mbid ]
getStats :: Connection -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Aff Stats
getStats conn mPeriod mFrom mTo mSection = do
@@ -306,12 +312,12 @@ getStats conn mPeriod mFrom mTo mSection = do
buildTimeFilterAndParams = case mFrom, mTo of
Just from, Just to ->
{ timeFilter: " AND s.listened_at >= CAST(epoch(TIMESTAMP ? || ' 00:00:00') AS INTEGER) AND s.listened_at < CAST(epoch(TIMESTAMP ? || ' 00:00:00') AS INTEGER) + 86400"
- , params: [ unsafeCoerce from, unsafeCoerce to ]
+ , params: [ toParam from, toParam to ]
}
_, _ -> case mPeriod >>= Int.fromString of
Just days ->
{ timeFilter: " AND s.listened_at >= CAST(epoch(now()) AS INTEGER) - ?"
- , params: [ unsafeCoerce (days * 86400) ]
+ , params: [ toParam (days * 86400) ]
}
Nothing ->
{ timeFilter: "", params: [] }
@@ -350,7 +356,7 @@ getArtistReleasesByMbids conn mbids = do
<> placeholders
<> ") AND artist_name != '' AND release_name != ''"
)
- (map unsafeCoerce mbids)
+ (map toParam mbids)
pure $ Object.fromFoldable (mapMaybe extractPair rows)
where
extractPair json = do
@@ -390,5 +396,5 @@ rowToListen json = do
getTokenUser :: Connection -> String -> Aff (Maybe String)
getTokenUser conn token = do
let hashedToken = sha256 token
- rows <- queryAll conn "SELECT slug FROM api_tokens WHERE hashed_token = ?" [ unsafeCoerce hashedToken ]
+ rows <- queryAll conn "SELECT slug FROM api_tokens WHERE hashed_token = ?" [ toParam hashedToken ]
pure $ rows !! 0 >>= toObject >>= Object.lookup "slug" >>= toString
diff --git a/src/Handler.purs b/src/Handler.purs
@@ -0,0 +1,47 @@
+module Handler
+ ( Response
+ , Request
+ , serveNotFound
+ , serveUnauthorized
+ , serveInternalError
+ , serveBadRequest
+ , serveError
+ , respond
+ ) where
+
+import Prelude
+
+import Effect (Effect)
+import Node.Encoding (Encoding(UTF8))
+import Node.HTTP.OutgoingMessage (setHeader, toWriteable)
+import Node.HTTP.ServerResponse (setStatusCode, toOutgoingMessage)
+import Node.Stream (end, writeString)
+import Node.HTTP.Types (ServerResponse, IncomingMessage, IMServer)
+
+type Request = IncomingMessage IMServer
+
+type Response = ServerResponse
+
+respond :: String -> Int -> String -> Response -> Effect Unit
+respond contentType statusCode body res = do
+ setHeader "Content-Type" contentType (toOutgoingMessage res)
+ setStatusCode statusCode res
+ let w = toWriteable (toOutgoingMessage res)
+ void $ writeString w UTF8 body
+ end w
+
+serveNotFound :: Response -> Effect Unit
+serveNotFound = respond "text/plain" 404 "Not Found"
+
+serveUnauthorized :: Response -> Effect Unit
+serveUnauthorized = respond "text/plain" 401 "Unauthorized"
+
+serveInternalError :: Response -> Effect Unit
+serveInternalError = respond "text/plain" 500 "Internal Server Error"
+
+serveBadRequest :: Response -> String -> Effect Unit
+serveBadRequest res message = respond "text/plain" 400 message res
+
+serveError :: Response -> Int -> String -> String -> Effect Unit
+serveError res statusCode statusName message =
+ respond "text/plain" statusCode (statusName <> ": " <> message) res
diff --git a/src/Main.purs b/src/Main.purs
@@ -23,18 +23,17 @@ import Effect.Aff.AVar (AVar)
import Effect.Aff.AVar as Avar
import Effect.Class (liftEffect)
import Effect.Exception as Exception
+import Node.Encoding (Encoding(UTF8))
import Log as Log
import Node.EventEmitter (on_)
import Metadata (enrichMetadata)
import Metrics as Metrics
-import Node.Encoding (Encoding(UTF8))
import Node.FS.Aff as FSA
import Node.HTTP (createServer)
import Node.HTTP.IncomingMessage as IM
import Node.HTTP.OutgoingMessage (setHeader, toWriteable)
import Node.HTTP.ServerResponse (setStatusCode, toOutgoingMessage)
import Node.HTTP.Server as Server
-import Node.HTTP.Types (ServerResponse, IncomingMessage, IMServer)
import Node.Net.Server (listenTcp, listeningH)
import Node.Process (argv, lookupEnv)
import Node.Stream (end, write, writeString)
@@ -44,15 +43,11 @@ import Web.URL (URL)
import Web.URL as URL
import Web.URL.URLSearchParams as URLSearchParams
import Command as Command
+import Handler (Request, Response, serveBadRequest, serveError, serveInternalError, serveNotFound, serveUnauthorized)
import Templates (indexHtml)
import Types (Listen(..), ListenBrainzAdditionalInfo(..), ListenBrainzSubmitListen(..), ListenBrainzSubmitPayload(..), ListenBrainzSubmitTrackMetadata(..), MbidMapping(..), TrackMetadata(..))
import Foreign.Object as Object
--- Types
-type Request = IncomingMessage IMServer
-
-type Response = ServerResponse
-
type UserContext =
{ conn :: Connection
, writeLock :: AVar Unit
@@ -335,46 +330,6 @@ submitTrackMetadataToTrackMetadata (ListenBrainzSubmitTrackMetadata { trackName,
}
}
-serveNotFound :: Response -> Effect Unit
-serveNotFound res = do
- setHeader "Content-Type" "text/plain" (toOutgoingMessage res)
- setStatusCode 404 res
- let w = toWriteable (toOutgoingMessage res)
- void $ writeString w UTF8 "Not Found"
- end w
-
-serveUnauthorized :: Response -> Effect Unit
-serveUnauthorized res = do
- setHeader "Content-Type" "text/plain" (toOutgoingMessage res)
- setStatusCode 401 res
- let w = toWriteable (toOutgoingMessage res)
- void $ writeString w UTF8 "Unauthorized"
- end w
-
-serveInternalError :: Response -> Effect Unit
-serveInternalError res = do
- setHeader "Content-Type" "text/plain" (toOutgoingMessage res)
- setStatusCode 500 res
- let w = toWriteable (toOutgoingMessage res)
- void $ writeString w UTF8 "Internal Server Error"
- end w
-
-serveBadRequest :: Response -> String -> Effect Unit
-serveBadRequest res message = do
- setHeader "Content-Type" "text/plain" (toOutgoingMessage res)
- setStatusCode 400 res
- let w = toWriteable (toOutgoingMessage res)
- void $ writeString w UTF8 message
- end w
-
-serveError :: Response -> Int -> String -> String -> Effect Unit
-serveError res statusCode statusName message = do
- setHeader "Content-Type" "text/plain" (toOutgoingMessage res)
- setStatusCode statusCode res
- let w = toWriteable (toOutgoingMessage res)
- void $ writeString w UTF8 (statusName <> ": " <> message)
- end w
-
startUser :: UserEntry -> Aff UserContext
startUser { slug, name, config } = do
Log.info $ "Starting user: " <> if slug == "" then "(root)" else slug
diff --git a/src/Sync.purs b/src/Sync.purs
@@ -18,14 +18,14 @@ import Data.Array (length, mapMaybe, null)
import Data.Either (Either(..))
import Data.Foldable (foldM, for_)
import Data.Maybe (Maybe(..), fromMaybe)
+import Data.String (Pattern(..), stripPrefix)
import Data.Time.Duration (Milliseconds(..))
-import Data.Tuple (Tuple(..))
import Db (Connection, checkExists, getOldestTs, upsertScrobble, withTransaction)
-import Effect.Aff (Aff, delay, launchAff_, makeAff, nonCanceler, try)
+import Effect.Aff (Aff, delay, launchAff_, makeAff, nonCanceler, throwError, try)
import Effect.Aff.AVar (AVar)
import Effect.Aff.Retry (RetryStatus(..), exponentialBackoff, limitRetries, recovering)
import Effect.Class (liftEffect)
-import Effect.Exception as Exception
+import Effect.Exception (error, message)
import Effect.Uncurried (mkEffectFn1)
import Fetch (fetch, Method(GET))
import Fetch.Argonaut.Json (fromJson)
@@ -38,19 +38,65 @@ import Node.HTTP.IncomingMessage as IM
import Node.HTTPS as HTTPS
import Node.Stream.Aff (readableToStringUtf8)
import Types (Listen(..), ListenBrainzResponse(..), MbidMapping(..), Payload(..), TrackMetadata(..), LastfmResponse(..), LastfmRecentTracks(..), LastfmAttr(..), LastfmTracks(..), LastfmArtist(..), LastfmAlbum(..), LastfmDate(..), LastfmTrack(..))
+-- | Cast required due to a gap in the node-http FFI bindings:
+-- | the request object lacks an "error" event emitter type.
import Unsafe.Coerce (unsafeCoerce)
+-- | Result of processing a batch of listens/scrobbles.
+type SyncResult =
+ { added :: Int
+ , hitCount :: Int
+ , minTs :: Maybe Int
+ }
+
+-- | Process a batch of listens: check existence, insert new ones, track stats.
+-- | When trackMinTs is true, the minimum timestamp is tracked (for cursor-based pagination).
+processTracks :: Connection -> Array Listen -> Boolean -> Aff SyncResult
+processTracks conn listens trackMinTs = do
+ foldM step { added: 0, hitCount: 0, minTs: Nothing } listens
+ where
+ step :: SyncResult -> Listen -> Aff SyncResult
+ step s l@(Listen { listenedAt: Just ts }) = do
+ exists <- checkExists conn ts
+ if exists then do
+ let nextMinTs = if trackMinTs then Just ts else s.minTs
+ pure $ s { added = s.added, hitCount = s.hitCount + 1, minTs = nextMinTs }
+ else do
+ upsertScrobble conn l
+ let nextMinTs = if trackMinTs then Just ts else s.minTs
+ pure $ s { added = s.added + 1, hitCount = s.hitCount, minTs = nextMinTs }
+ step s (Listen { listenedAt: Nothing }) = do
+ Log.warn "Skipping scrobble without timestamp"
+ pure s
+
+-- | Wraps unsafeCoerce for attaching error handlers to HTTP requests.
+-- | This is the only legitimate use of unsafeCoerce in this module.
+castRequestForError :: forall a. a -> a
+castRequestForError = unsafeCoerce
+
listenBrainzUrl :: String -> String
listenBrainzUrl username = "https://api.listenbrainz.org/1/user/" <> username <> "/listens"
+-- | Retry an action with exponential backoff, but only for transient errors.
+-- | Parse errors and other permanent failures are not retried.
withRetry :: forall a. String -> Aff a -> Aff a
-withRetry label action = recovering policy [ \_ _ -> pure true ] \(RetryStatus status) -> do
+withRetry label action = recovering policy [ \_ err -> pure $ isTransientError err ] \(RetryStatus status) -> do
when (status.iterNumber > 0)
$ Log.warn
$ label <> " failed, retry attempt " <> show status.iterNumber
action
where
policy = exponentialBackoff (Milliseconds 1000.0) <> limitRetries 5
+ isTransientError err = not isPermanent
+ where
+ msg = message err
+ isPermanent =
+ msg == "Last.fm: Failed to parse JSON response"
+ || startsWith "Last.fm API returned status" msg
+ || startsWith "ListenBrainz API returned status" msg
+ startsWith prefix str = case stripPrefix (Pattern prefix) str of
+ Just _ -> true
+ Nothing -> false
fetchListenBrainzUrl :: String -> Aff String
fetchListenBrainzUrl url = withRetry "ListenBrainz fetch" $ makeAff \callback -> do
@@ -66,10 +112,10 @@ fetchListenBrainzUrl url = withRetry "ListenBrainz fetch" $ makeAff \callback ->
if IM.statusCode res == 200 then
callback (Right body)
else
- callback (Left $ Exception.error $ "ListenBrainz API returned status " <> show (IM.statusCode res))
+ callback (Left $ error $ "ListenBrainz API returned status " <> show (IM.statusCode res))
let errorH = EventHandle "error" mkEffectFn1
- on_ errorH (\err -> callback (Left err)) (unsafeCoerce req)
+ on_ errorH (\err -> callback (Left err)) (castRequestForError req)
pure nonCanceler
@@ -94,9 +140,9 @@ fetchLastfmPage apiKey lfmUser page mTo = withRetry "Last.fm fetch" do
pure result
Nothing -> do
Log.error $ "Last.fm: Failed to parse JSON response: " <> stringify json
- liftEffect $ Exception.error "Last.fm: Failed to parse JSON response" # Exception.throwException
+ throwError $ error "Last.fm: Failed to parse JSON response"
else do
- liftEffect $ Exception.error ("Last.fm API returned status " <> show fr.status) # Exception.throwException
+ throwError $ error ("Last.fm API returned status " <> show fr.status)
parseLastfmResponse :: Json -> Maybe { tracks :: Array Json, totalPages :: Int }
parseLastfmResponse json = case decodeJson json of
@@ -144,7 +190,7 @@ lbSync conn username slug writeLock = void do
result <- try $ fetchListenBrainzUrl (listenBrainzUrl username <> "?count=100")
case result of
Left err -> do
- Log.error $ "Sync fetch error: " <> Exception.message err
+ Log.error $ "Sync fetch error: " <> message err
liftEffect $ Metrics.incSyncRuns slug "listenbrainz" "error"
Right body ->
case parseJson body >>= decodeJson of
@@ -152,7 +198,11 @@ lbSync conn username slug writeLock = void do
Log.error $ "Sync parse error: " <> show err
liftEffect $ Metrics.incSyncRuns slug "listenbrainz" "error"
Right (ListenBrainzResponse { payload: Payload { listens } }) -> do
- Tuple added (Tuple minTs hitCount) <- withTransaction conn writeLock (processListens listens)
+ syncResult <- withTransaction conn writeLock (processListens listens)
+ let
+ added = syncResult.added
+ minTs = syncResult.minTs
+ hitCount = syncResult.hitCount
Log.info $ "ListenBrainz batch 1: added " <> show added <> ", " <> show hitCount <> " already present."
let allExist = hitCount == length listens && not (null listens)
if allExist || null listens then do
@@ -171,7 +221,7 @@ lbSync conn username slug writeLock = void do
result <- try $ fetchListenBrainzUrl (listenBrainzUrl username <> "?count=100&max_ts=" <> show ts)
case result of
Left err -> do
- Log.error $ "Sync fetch error: " <> Exception.message err
+ Log.error $ "Sync fetch error: " <> message err
pure acc
Right body ->
case parseJson body >>= decodeJson of
@@ -179,7 +229,11 @@ lbSync conn username slug writeLock = void do
Log.error $ "Sync parse error: " <> show err
pure acc
Right (ListenBrainzResponse { payload: Payload { listens } }) -> do
- Tuple added (Tuple newMinTs hitCount) <- withTransaction conn writeLock (processListens listens)
+ syncResult <- withTransaction conn writeLock (processListens listens)
+ let
+ added = syncResult.added
+ newMinTs = syncResult.minTs
+ hitCount = syncResult.hitCount
Log.info $ "ListenBrainz batch " <> show batchNum <> ": added " <> show added <> ", " <> show hitCount <> " already present."
let allExist = hitCount == length listens && not (null listens)
if allExist || null listens then
@@ -187,19 +241,7 @@ lbSync conn username slug writeLock = void do
else
paginateUntilDone (batchNum + 1) newMinTs (acc + added)
- processListens listens = do
- s <- foldM step { added: 0, minTs: Nothing, hitCount: 0 } listens
- pure $ Tuple s.added (Tuple s.minTs s.hitCount)
- where
- step s l@(Listen { listenedAt: Just ts }) = do
- exists <- checkExists conn ts
- if exists then pure s { minTs = Just ts, hitCount = s.hitCount + 1 }
- else do
- upsertScrobble conn l
- pure s { added = s.added + 1, minTs = Just ts }
- step s _ = do
- Log.warn "Skipping scrobble without timestamp"
- pure s
+ processListens listens = processTracks conn listens true
lbSyncLoop :: Connection -> String -> String -> AVar Unit -> Aff Unit
lbSyncLoop conn username slug writeLock = forever do
@@ -216,10 +258,13 @@ lfSync conn apiKey lfmUser slug writeLock = do
res <- try $ fetchLastfmPage apiKey lfmUser 1 Nothing
case res of
Left err -> do
- Log.error $ "Last.fm sync fetch error: " <> Exception.message err
+ Log.error $ "Last.fm sync fetch error: " <> message err
liftEffect $ Metrics.incSyncRuns slug "lastfm" "error"
Right { tracks, totalPages } -> do
- Tuple added hitCount <- withTransaction conn writeLock (processLastfmTracks tracks)
+ result <- withTransaction conn writeLock (processLastfmTracks tracks)
+ let
+ added = result.added
+ hitCount = result.hitCount
Log.info $ "Last.fm page 1/" <> show totalPages <> ": added " <> show added <> ", " <> show hitCount <> " already present."
let
validTracks = mapMaybe lastfmTrackToListen tracks
@@ -239,11 +284,14 @@ lfSync conn apiKey lfmUser slug writeLock = do
res <- try $ fetchLastfmPage apiKey lfmUser page mTo
case res of
Left err -> do
- Log.error $ "Last.fm sync fetch error: " <> Exception.message err
+ Log.error $ "Last.fm sync fetch error: " <> message err
pure acc
Right { tracks } -> do
- Tuple added hitCount <- withTransaction conn writeLock (processLastfmTracks tracks)
- Log.info $ "Last.fm page " <> show page <> "/" <> show totalPages <> ": added " <> show added <> ", " <> show hitCount <> " already present."
+ result <- withTransaction conn writeLock (processLastfmTracks tracks)
+ let
+ added = result.added
+ hitCount = result.hitCount
+ Log.info $ "Last.fm page" <> show page <> "/" <> show totalPages <> ": added " <> show added <> ", " <> show hitCount <> " already present."
let
validTracks = mapMaybe lastfmTrackToListen tracks
allExist = hitCount == length validTracks && not (null validTracks)
@@ -257,28 +305,21 @@ lfSync conn apiKey lfmUser slug writeLock = do
res <- try $ fetchLastfmPage apiKey lfmUser 1 (Just (oldestTs - 1))
case res of
Left err ->
- Log.error $ "Last.fm backfill fetch error: " <> Exception.message err
+ Log.error $ "Last.fm backfill fetch error: " <> message err
Right { tracks, totalPages } ->
if null tracks then
Log.info "No older Last.fm history found."
else do
Log.info $ "Backfilling " <> show totalPages <> " pages of Last.fm history before " <> show oldestTs
- Tuple added hitCount <- withTransaction conn writeLock (processLastfmTracks tracks)
+ result <- withTransaction conn writeLock (processLastfmTracks tracks)
+ let
+ added = result.added
+ hitCount = result.hitCount
Log.info $ "Last.fm backfill page 1/" <> show totalPages <> ": added " <> show added <> ", " <> show hitCount <> " already present."
total <- paginateLastfmUntilDone 2 totalPages (Just (oldestTs - 1)) added
Log.info $ "Last.fm backfill complete. Added " <> show total <> " older scrobbles."
- processLastfmTracks tracks = do
- s <- foldM step { added: 0, hitCount: 0 } (mapMaybe lastfmTrackToListen tracks)
- pure $ Tuple s.added s.hitCount
- where
- step s l@(Listen { listenedAt: Just ts }) = do
- exists <- checkExists conn ts
- if exists then pure s { hitCount = s.hitCount + 1 }
- else do
- upsertScrobble conn l
- pure s { added = s.added + 1 }
- step s _ = pure s
+ processLastfmTracks tracks = processTracks conn (mapMaybe lastfmTrackToListen tracks) false
lfSyncLoop :: Connection -> String -> String -> String -> AVar Unit -> Aff Unit
lfSyncLoop conn apiKey lfmUser slug writeLock = forever do
