monatone-0.4.0.0: src/Monatone/MP3.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
module Monatone.MP3
( parseMP3
, loadAlbumArtMP3
, extractRawFrames
) where
import Control.Applicative ((<|>))
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Except (throwError)
import Data.Binary.Get
import Data.Bits
import Data.Char (isDigit)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Word
import System.IO (Handle, IOMode(..), hSeek, SeekMode(..), hFileSize, hTell)
import System.OsPath
import System.File.OsPath (withBinaryFile)
import qualified Data.HashMap.Strict as HM
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TEE
import Monatone.Metadata
import Monatone.Types
-- | ID3v2 signature "ID3" in bytes
id3v2Signature :: BS.ByteString
id3v2Signature = "ID3"
-- | Parse MP3 file efficiently - only read ID3 tags and frame headers
parseMP3 :: OsPath -> Parser Metadata
parseMP3 filePath = do
result <- liftIO $ withBinaryFile filePath ReadMode $ \handle -> do
-- Parse ID3v2 tag at beginning if present
metadata <- parseID3v2FromHandle handle (emptyMetadata MP3)
-- Parse ID3v1 tag at end if present (last 128 bytes)
metadataWithId3v1 <- parseID3v1FromHandle handle metadata
-- Parse MP3 audio properties from first frame
audioProps <- parseMP3AudioPropertiesFromHandle handle
return $ Right $ metadataWithId3v1 { audioProperties = audioProps }
case result of
Left err -> throwError err
Right m -> return m
-- | Parse ID3v2 tag from file handle if present
parseID3v2FromHandle :: Handle -> Metadata -> IO Metadata
parseID3v2FromHandle handle metadata = do
-- Read first 10 bytes (ID3v2 header)
hSeek handle AbsoluteSeek 0
header <- BS.hGet handle 10
if BS.length header < 10 || BS.take 3 header /= id3v2Signature
then return metadata -- No ID3v2 tag
else do
-- Parse header to get tag size
let version = BS.index header 3
_minorVersion = BS.index header 4
flags = BS.index header 5
-- Size is synchsafe integer (7 bits per byte)
size = parseSynchsafeInt (BS.drop 6 header)
-- Read only the ID3v2 tag data
tagData <- BS.hGet handle (fromIntegral size)
-- Parse based on version
return $ parseID3v2Tag version flags tagData metadata
-- | Parse synchsafe integer (ID3v2 uses 7 bits per byte for sizes)
parseSynchsafeInt :: BS.ByteString -> Word32
parseSynchsafeInt bs =
case map fromIntegral $ BS.unpack $ BS.take 4 bs of
[b1, b2, b3, b4] -> (b1 `shiftL` 21) .|. (b2 `shiftL` 14) .|. (b3 `shiftL` 7) .|. b4
_ -> 0 -- Should not happen with BS.take 4, but handle gracefully
-- | Reverse ID3v2 unsynchronisation (0xFF 0x00 -> 0xFF)
removeUnsync :: BS.ByteString -> BS.ByteString
removeUnsync bs = BS.pack (go (BS.unpack bs))
where
go (0xFF : 0x00 : rest) = 0xFF : go rest
go (b : rest) = b : go rest
go [] = []
-- | Skip the ID3v2 extended header if present. In v2.4 its size field is a
-- syncsafe integer that includes itself; in v2.3 it is a plain 32-bit
-- integer that excludes itself
skipExtendedHeader :: Word8 -> BS.ByteString -> BS.ByteString
skipExtendedHeader version bs
| BS.length bs < 4 = bs
| version >= 4 = BS.drop (max 4 (fromIntegral (parseSynchsafeInt bs))) bs
| otherwise = BS.drop (4 + fromIntegral (runGet getWord32be (L.fromStrict (BS.take 4 bs)))) bs
-- | Parse ID3v2 tag data
parseID3v2Tag :: Word8 -> Word8 -> BS.ByteString -> Metadata -> Metadata
parseID3v2Tag version flags rawTagData metadata =
let unsynced = if flags .&. 0x80 /= 0 then removeUnsync rawTagData else rawTagData
tagData = if flags .&. 0x40 /= 0 then skipExtendedHeader version unsynced else unsynced
frames = if version >= 3
then concatMap classifyFrame (extractRawFramesFromPayload version tagData)
else parseID3v22Frames (L.fromStrict tagData)
-- Repeated frames keep every value; scalar fields take the first
tagMap = HM.fromListWith (flip (<>)) [(k, [v]) | (k, v) <- frames]
firstOf key = HM.lookup key tagMap >>= listToMaybe
-- Try to find and parse APIC frame for album art info (metadata only, not image data)
parsedAlbumArtInfo = findAndParseAPICInfo version (L.fromStrict tagData)
in metadata
{ title = firstOf "TIT2" <|> firstOf "TT2"
, artist = firstOf "TPE1" <|> firstOf "TP1"
, album = firstOf "TALB" <|> firstOf "TAL"
, albumArtist = firstOf "TPE2" <|> firstOf "TP2"
, trackNumber = (firstOf "TRCK" <|> firstOf "TRK") >>= parseTrackNumber
, totalTracks = (firstOf "TRCK" <|> firstOf "TRK") >>= parseTotal
, discNumber = (firstOf "TPOS" <|> firstOf "TPA") >>= parseTrackNumber
, totalDiscs = (firstOf "TPOS" <|> firstOf "TPA") >>= parseTotal
, year = ((firstOf "TYER" <|> firstOf "TYE") >>= readInt)
<|> (firstOf "TDRC" >>= extractYearFromDate)
, date = firstOf "TDRC"
, genre = resolveGenre <$> (firstOf "TCON" <|> firstOf "TCO")
, comment = firstOf "COMM" <|> firstOf "COM" <|> firstOf "TXXX:comment"
, publisher = firstOf "TPUB"
, recordLabel = firstOf "TXXX:LABEL" <|> firstOf "TPUB"
, catalogNumber = firstOf "TXXX:CATALOGNUMBER"
, barcode = firstOf "TXXX:BARCODE"
, releaseCountry = firstOf "TXXX:MusicBrainz Album Release Country"
, releaseStatus = firstOf "TXXX:MusicBrainz Album Status"
, releaseType = firstOf "TXXX:MusicBrainz Album Type"
, albumArtInfo = parsedAlbumArtInfo
, musicBrainzIds = extractMusicBrainzIds firstOf
, acoustidFingerprint = extractAcoustidFingerprint firstOf
, acoustidId = extractAcoustidId firstOf
, rawTags = tagMap -- Populate rawTags with all parsed frames
}
where
parseTrackNumber t = case T.split (== '/') t of
(n:_) -> readInt n
_ -> Nothing
parseTotal t = case T.split (== '/') t of
(_:total:_) -> readInt total
_ -> Nothing
extractMusicBrainzIds firstOf = MusicBrainzIds
{ mbTrackId = firstOf "TXXX:MusicBrainz Release Track Id"
-- Picard stores the recording id in UFID:http://musicbrainz.org
, mbRecordingId = firstOf "UFID:http://musicbrainz.org"
<|> firstOf "TXXX:MusicBrainz Recording Id"
, mbReleaseId = firstOf "TXXX:MusicBrainz Album Id"
, mbReleaseGroupId = firstOf "TXXX:MusicBrainz Release Group Id"
, mbArtistId = firstOf "TXXX:MusicBrainz Artist Id"
, mbAlbumArtistId = firstOf "TXXX:MusicBrainz Album Artist Id"
, mbWorkId = firstOf "TXXX:MusicBrainz Work Id"
, mbDiscId = firstOf "TXXX:MusicBrainz Disc Id"
}
extractAcoustidFingerprint firstOf =
firstOf "TXXX:Acoustid Fingerprint" <|>
firstOf "TXXX:ACOUSTID_FINGERPRINT" <|>
firstOf "TXXX:acoustid_fingerprint"
extractAcoustidId firstOf =
firstOf "TXXX:Acoustid Id" <|>
firstOf "TXXX:ACOUSTID_ID" <|>
firstOf "TXXX:acoustid_id"
-- | Extract raw frames (id, decoded content) from a complete ID3v2.3/2.4
-- tag payload, honouring tag-level unsynchronisation, the extended header
-- and v2.4 per-frame format flags. Exposed so the writer can carry binary
-- frames (USLT, APIC, PRIV, GEOB, UFID, ...) through an update verbatim.
extractRawFrames :: Word8 -> Word8 -> BS.ByteString -> [(BS.ByteString, BS.ByteString)]
extractRawFrames version flags rawTagData
| version < 3 = [] -- v2.2 frames cannot be carried into a v2.4 tag
| otherwise =
let unsynced = if flags .&. 0x80 /= 0 then removeUnsync rawTagData else rawTagData
tagData = if flags .&. 0x40 /= 0 then skipExtendedHeader version unsynced else unsynced
in extractRawFramesFromPayload version tagData
-- | Like extractRawFrames, but for a payload whose tag-level
-- unsynchronisation and extended header are already dealt with
extractRawFramesFromPayload :: Word8 -> BS.ByteString -> [(BS.ByteString, BS.ByteString)]
extractRawFramesFromPayload version payload = go (L.fromStrict payload)
where
go bs
| L.length bs < 10 = []
| otherwise =
case runGetOrFail rawFrame bs of
Left _ -> []
Right (rest, _, frame) -> frame : go rest
rawFrame = do
frameId <- getByteString 4
-- Check for padding
if BS.all (== 0) frameId
then fail "Padding reached"
else do
-- Frame size (synchsafe for v2.4, normal for v2.3)
frameSize <- if version >= 4
then do
b1 <- getWord8
b2 <- getWord8
b3 <- getWord8
b4 <- getWord8
return $ (fromIntegral b1 `shiftL` 21) .|.
(fromIntegral b2 `shiftL` 14) .|.
(fromIntegral b3 `shiftL` 7) .|.
(fromIntegral b4 :: Word32)
else getWord32be
frameFlags <- getWord16be
rawData <- getByteString (fromIntegral frameSize)
-- v2.4 format flags: 0x01 = data length indicator prepended (4
-- bytes), 0x02 = frame content is unsynchronised
let content
| version >= 4 =
let afterDli = if frameFlags .&. 0x01 /= 0 then BS.drop 4 rawData else rawData
in if frameFlags .&. 0x02 /= 0 then removeUnsync afterDli else afterDli
| otherwise = rawData
return (frameId, content)
-- | Turn a raw frame into tag-map entries
classifyFrame :: (BS.ByteString, BS.ByteString) -> [(Text, Text)]
classifyFrame (frameId, frameData)
| frameId == "APIC" = [] -- picture frames are handled separately
| frameId == "COMM" = [(frameIdText, parseCOMMFrame frameData)]
| frameId == "TXXX" =
let (finalId, values) = parseTXXXFrame frameData
in [(finalId, v) | v <- values]
| frameId == "USLT" = [(frameIdText, parseUSLTFrame frameData)]
| frameId == "UFID" = [parseUFIDFrame frameData]
| otherwise = [(frameIdText, v) | v <- parseFrameContent frameData]
where
frameIdText = TE.decodeUtf8With TEE.lenientDecode frameId
-- | Parse ID3v2.2 frames (3-character IDs)
parseID3v22Frames :: L.ByteString -> [(Text, Text)]
parseID3v22Frames bs
| L.length bs < 6 = []
| otherwise =
case runGetOrFail parseID3v22Frame bs of
Left _ -> []
Right (rest, _, pairs) ->
pairs ++ parseID3v22Frames rest
parseID3v22Frame :: Get [(Text, Text)]
parseID3v22Frame = do
frameId <- getByteString 3
-- Check for padding
if BS.all (== 0) frameId
then fail "Padding reached"
else do
-- 24-bit size (big-endian)
sizeByte1 <- getWord8
sizeByte2 <- getWord8
sizeByte3 <- getWord8
let frameSize = ((fromIntegral sizeByte1 :: Word32) `shiftL` 16) .|.
((fromIntegral sizeByte2 :: Word32) `shiftL` 8) .|.
(fromIntegral sizeByte3 :: Word32)
frameData <- getByteString (fromIntegral frameSize)
-- Skip PIC frames (ID3v2.2 version of APIC)
if frameId == "PIC"
then return []
else do
let frameIdText = TE.decodeUtf8With TEE.lenientDecode frameId
return $
if frameId == "COM"
then [(frameIdText, parseCOMMFrame frameData)]
else if frameId == "TXX"
then [(frameIdText, v) | v <- snd (parseTXXXFrame frameData)] -- v2.2 doesn't have description prefix
else if frameId == "ULT"
then [(frameIdText, parseUSLTFrame frameData)]
else [(frameIdText, v) | v <- parseFrameContent frameData]
-- | Parse text frame content. ID3v2.4 text frames may carry several
-- null-separated values (and taggers write them in v2.3 files too), so
-- this returns every value rather than mashing them into one string
parseFrameContent :: BS.ByteString -> [Text]
parseFrameContent bs
| BS.null bs = []
| otherwise =
filter (not . T.null) $ T.split (== '\0') $
decodeID3Text (BS.head bs) (BS.tail bs)
-- | Split at the text terminator for the given ID3 encoding: a 2-byte
-- aligned double null for the UTF-16 encodings, a single null otherwise.
-- Alignment matters: an unaligned search matches the null pair straddling
-- a UTF-16 code unit boundary (e.g. LE "A" = 41 00 followed by 00 00) and
-- shifts every following code unit by one byte.
-- Returns (before terminator, after terminator); with no terminator the
-- whole input is "before" and "after" is empty
splitAtTerminator :: Word8 -> BS.ByteString -> (BS.ByteString, BS.ByteString)
splitAtTerminator encoding bs
| encoding == 1 || encoding == 2 = go 0
| otherwise =
let (before, after) = BS.break (== 0) bs
in (before, BS.drop 1 after)
where
go i
| i + 1 >= BS.length bs = (bs, BS.empty)
| BS.index bs i == 0 && BS.index bs (i + 1) == 0 = (BS.take i bs, BS.drop (i + 2) bs)
| otherwise = go (i + 2)
-- | Decode text for the given ID3 encoding byte
decodeID3Text :: Word8 -> BS.ByteString -> Text
decodeID3Text 0 bytes = TE.decodeLatin1 bytes
decodeID3Text 1 bytes -- UTF-16 with BOM
| BS.length bytes >= 2 = case (BS.index bytes 0, BS.index bytes 1) of
(0xFF, 0xFE) -> TE.decodeUtf16LEWith TEE.lenientDecode (BS.drop 2 bytes)
(0xFE, 0xFF) -> TE.decodeUtf16BEWith TEE.lenientDecode (BS.drop 2 bytes)
_ -> TE.decodeUtf16LEWith TEE.lenientDecode bytes
| otherwise = ""
decodeID3Text 2 bytes = TE.decodeUtf16BEWith TEE.lenientDecode bytes
decodeID3Text _ bytes = TE.decodeUtf8With TEE.lenientDecode bytes
-- | Parse COMM (comment) frame which has special structure
parseCOMMFrame :: BS.ByteString -> Text
parseCOMMFrame bs
| BS.length bs < 5 = "" -- Need at least encoding + language (3) + content
| otherwise =
let encoding = BS.head bs
rest = BS.drop 4 bs -- Skip encoding + 3-byte language code
(_description, content) = splitAtTerminator encoding rest
in decodeID3Text encoding content
-- | Parse TXXX frame (user-defined text information frame)
-- Returns (frameId with description, values); the value part may hold
-- several null-separated values like any other text frame
parseTXXXFrame :: BS.ByteString -> (Text, [Text])
parseTXXXFrame bs
| BS.null bs = ("TXXX", [])
| otherwise =
let encoding = BS.head bs
rest = BS.tail bs
(descBytes, valueBytes) = splitAtTerminator encoding rest
description = T.filter (/= '\0') $ decodeID3Text encoding descBytes
values = filter (not . T.null) $ T.split (== '\0') $
decodeID3Text encoding valueBytes
frameId = if T.null description then "TXXX" else "TXXX:" <> description
in (frameId, values)
-- | The ID3v1 genre list (0-79) plus the Winamp extensions (80-147)
id3v1Genres :: [Text]
id3v1Genres =
[ "Blues", "Classic Rock", "Country", "Dance", "Disco", "Funk", "Grunge"
, "Hip-Hop", "Jazz", "Metal", "New Age", "Oldies", "Other", "Pop", "R&B"
, "Rap", "Reggae", "Rock", "Techno", "Industrial", "Alternative", "Ska"
, "Death Metal", "Pranks", "Soundtrack", "Euro-Techno", "Ambient"
, "Trip-Hop", "Vocal", "Jazz+Funk", "Fusion", "Trance", "Classical"
, "Instrumental", "Acid", "House", "Game", "Sound Clip", "Gospel", "Noise"
, "AlternRock", "Bass", "Soul", "Punk", "Space", "Meditative"
, "Instrumental Pop", "Instrumental Rock", "Ethnic", "Gothic", "Darkwave"
, "Techno-Industrial", "Electronic", "Pop-Folk", "Eurodance", "Dream"
, "Southern Rock", "Comedy", "Cult", "Gangsta", "Top 40", "Christian Rap"
, "Pop/Funk", "Jungle", "Native American", "Cabaret", "New Wave"
, "Psychadelic", "Rave", "Showtunes", "Trailer", "Lo-Fi", "Tribal"
, "Acid Punk", "Acid Jazz", "Polka", "Retro", "Musical", "Rock & Roll"
, "Hard Rock", "Folk", "Folk-Rock", "National Folk", "Swing", "Fast Fusion"
, "Bebob", "Latin", "Revival", "Celtic", "Bluegrass", "Avantgarde"
, "Gothic Rock", "Progressive Rock", "Psychedelic Rock", "Symphonic Rock"
, "Slow Rock", "Big Band", "Chorus", "Easy Listening", "Acoustic", "Humour"
, "Speech", "Chanson", "Opera", "Chamber Music", "Sonata", "Symphony"
, "Booty Bass", "Primus", "Porn Groove", "Satire", "Slow Jam", "Club"
, "Tango", "Samba", "Folklore", "Ballad", "Power Ballad", "Rhythmic Soul"
, "Freestyle", "Duet", "Punk Rock", "Drum Solo", "A Cappella", "Euro-House"
, "Dance Hall", "Goa", "Drum & Bass", "Club-House", "Hardcore", "Terror"
, "Indie", "BritPop", "Negerpunk", "Polsk Punk", "Beat"
, "Christian Gangsta Rap", "Heavy Metal", "Black Metal", "Crossover"
, "Contemporary Christian", "Christian Rock", "Merengue", "Salsa"
, "Thrash Metal", "Anime", "Jpop", "Synthpop"
]
genreByIndex :: Int -> Maybe Text
genreByIndex i
| i >= 0 && i < length id3v1Genres = Just (id3v1Genres !! i)
| otherwise = Nothing
-- | Resolve numeric genre references: ID3v2.3 "(17)" (optionally followed
-- by a textual refinement, which wins) and ID3v2.4 bare numeric strings
resolveGenre :: Text -> Text
resolveGenre t
| Just rest <- T.stripPrefix "(" t
, (digits, closeAndAfter) <- T.span isDigit rest
, Just after <- T.stripPrefix ")" closeAndAfter
, not (T.null digits)
= if T.null after
then fromMaybe t (readInt digits >>= genreByIndex)
else after
| not (T.null t), T.all isDigit t
= fromMaybe t (readInt t >>= genreByIndex)
| otherwise = t
-- | Parse UFID frame (unique file identifier): a null-terminated Latin-1
-- owner URL followed by the identifier. MusicBrainz identifiers are ASCII
-- UUIDs, so the identifier is decoded as text.
parseUFIDFrame :: BS.ByteString -> (Text, Text)
parseUFIDFrame bs =
let (owner, rest) = BS.break (== 0) bs
identifier = BS.drop 1 rest
in ( "UFID:" <> TE.decodeLatin1 owner
, T.filter (/= '\0') $ TE.decodeUtf8With TEE.lenientDecode identifier
)
-- | Parse USLT frame (unsynchronized lyrics/text transcription)
parseUSLTFrame :: BS.ByteString -> Text
parseUSLTFrame bs
| BS.length bs < 5 = "" -- Need at least encoding + language (3) + content
| otherwise =
let encoding = BS.head bs
rest = BS.drop 4 bs -- Skip encoding + 3-byte language code
(_descriptor, lyricsBytes) = splitAtTerminator encoding rest
in T.filter (/= '\0') $ decodeID3Text encoding lyricsBytes
-- | Parse ID3v1 tag from file handle if present
parseID3v1FromHandle :: Handle -> Metadata -> IO Metadata
parseID3v1FromHandle handle metadata = do
fileSize <- hFileSize handle
if fileSize > 128
then do
hSeek handle AbsoluteSeek (fileSize - 128)
id3v1Data <- BS.hGet handle 128
if BS.take 3 id3v1Data == "TAG"
then return $ parseID3v1Tag id3v1Data metadata
else return metadata
else return metadata
-- | Parse ID3v1 tag
parseID3v1Tag :: BS.ByteString -> Metadata -> Metadata
parseID3v1Tag bs metadata = metadata
{ title = title metadata <|> parseID3v1Field bs 3 30
, artist = artist metadata <|> parseID3v1Field bs 33 30
, album = album metadata <|> parseID3v1Field bs 63 30
, year = year metadata <|> (parseID3v1Field bs 93 4 >>= readInt)
, comment = comment metadata <|> parseID3v1Field bs 97 commentLength
, genre = genre metadata <|> genreByIndex (fromIntegral $ BS.index bs 127)
, trackNumber = trackNumber metadata <|>
if hasTrackNumber
then Just (fromIntegral $ BS.index bs 126)
else Nothing
}
where
-- ID3v1.1 shortens the comment to 28 bytes to fit a track number,
-- marked by a null at byte 125; plain v1.0 comments are 30 bytes
hasTrackNumber = BS.index bs 125 == 0 && BS.index bs 126 /= 0
commentLength = if hasTrackNumber then 28 else 30
parseID3v1Field bytes offset len =
let field = BS.take len (BS.drop offset bytes)
cleaned = BS.takeWhile (/= 0) field
-- ID3v1 predates Unicode: fields are Latin-1, not UTF-8
in if BS.null cleaned
then Nothing
else Just $ TE.decodeLatin1 cleaned
-- | Parse MP3 audio properties from file handle
parseMP3AudioPropertiesFromHandle :: Handle -> IO AudioProperties
parseMP3AudioPropertiesFromHandle handle = do
-- Skip ID3v2 tag if present
hSeek handle AbsoluteSeek 0
startPos <- skipID3v2 handle
-- Get file size for duration calculation
fileSize <- hFileSize handle
-- Seek to where audio should start
hSeek handle AbsoluteSeek startPos
-- Search for MP3 frame sync within first 1MB (like mutagen)
frameHeader <- findMP3FrameSync handle (1024 * 1024)
case frameHeader of
Just header -> do
-- Parse basic frame info
let props = parseMP3FrameHeader header
-- Try to find VBR headers (Xing/Info or VBRI)
currentPos <- hTell handle
hSeek handle AbsoluteSeek (currentPos - 4) -- Go back to frame start
vbrProps <- parseVBRHeaders handle props
-- If no duration calculated yet (CBR file), calculate from file size and bitrate
let finalProps = case (duration vbrProps, bitrate vbrProps) of
(Nothing, Just br) | br > 0 ->
let audioSize = fileSize - startPos -- Exclude ID3 tags
durationSecs = (fromIntegral audioSize * 8) / (fromIntegral br * 1000) :: Double
durationMs = round (durationSecs * 1000) :: Int
in vbrProps { duration = Just durationMs }
_ -> vbrProps
return finalProps
Nothing -> return emptyAudioProperties
-- | Skip ID3v2 tag and return position after it
skipID3v2 :: Handle -> IO Integer
skipID3v2 handle = do
header <- BS.hGet handle 10
if BS.length header < 10 || BS.take 3 header /= "ID3"
then return 0
else do
let size = parseSynchsafeInt (BS.drop 6 header)
-- The v2.4 footer flag adds 10 bytes after the tag data
footerSize = if BS.index header 5 .&. 0x10 /= 0 then 10 else 0 :: Integer
return $ 10 + fromIntegral size + footerSize
-- | Find MP3 frame sync
findMP3FrameSync :: Handle -> Int -> IO (Maybe BS.ByteString)
findMP3FrameSync handle maxBytes = searchSync 0
where
searchSync bytesRead'
| bytesRead' >= maxBytes = return Nothing
| otherwise = do
chunk <- BS.hGet handle (min 4096 (maxBytes - bytesRead'))
if BS.null chunk
then return Nothing
else case findSync chunk of
Just pos -> do
hSeek handle RelativeSeek (fromIntegral pos - fromIntegral (BS.length chunk))
header <- BS.hGet handle 4
-- A sync pattern right at EOF yields a short header, which
-- parseMP3FrameHeader cannot index into
return $ if BS.length header == 4 then Just header else Nothing
Nothing
-- A sync pattern can straddle the chunk boundary (0xFF as
-- the last byte of one chunk); step back one byte so it
-- pairs with the next chunk
| BS.length chunk > 1 -> do
hSeek handle RelativeSeek (-1)
searchSync (bytesRead' + BS.length chunk - 1)
| otherwise -> searchSync (bytesRead' + BS.length chunk)
findSync bs =
let indices = [i | i <- [0..BS.length bs - 2]
, BS.index bs i == 0xFF
, (BS.index bs (i+1) .&. 0xE0) == 0xE0]
in case indices of
(i:_) -> Just i
_ -> Nothing
-- | Parse MP3 frame header
parseMP3FrameHeader :: BS.ByteString -> AudioProperties
parseMP3FrameHeader header =
let byte2 = BS.index header 1
versionBits = (byte2 `shiftR` 3) .&. 0x03
layerBits = (byte2 `shiftR` 1) .&. 0x03
byte3 = BS.index header 2
bitrateBits = (byte3 `shiftR` 4) .&. 0x0F
sampleRateBits = (byte3 `shiftR` 2) .&. 0x03
_paddingBit = (byte3 `shiftR` 1) .&. 0x01
byte4 = BS.index header 3
channelMode = (byte4 `shiftR` 6) .&. 0x03
-- Determine MPEG version
version = case versionBits of
0 -> 2.5 :: Double -- MPEG 2.5
2 -> 2 -- MPEG 2
3 -> 1 -- MPEG 1
_ -> 1 -- Invalid, default to 1
-- Determine layer
layer = case layerBits of
1 -> 3 :: Int -- Layer III
2 -> 2 -- Layer II
3 -> 1 -- Layer I
_ -> 0 -- Invalid
-- Look up sample rate
sampleRate' = case (versionBits, sampleRateBits) of
(0, 0) -> 11025 -- MPEG 2.5
(0, 1) -> 12000
(0, 2) -> 8000
(2, 0) -> 22050 -- MPEG 2
(2, 1) -> 24000
(2, 2) -> 16000
(3, 0) -> 44100 -- MPEG 1
(3, 1) -> 48000
(3, 2) -> 32000
_ -> 44100
-- Look up bitrate (in kbps)
-- This is for Layer III (MP3)
bitrate' = if layer == 3 && bitrateBits /= 0 && bitrateBits /= 15
then case version of
1 -> [0, 32, 40, 48, 56, 64, 80, 96, 112, 128, 160, 192, 224, 256, 320, 0] !! fromIntegral bitrateBits
_ -> [0, 8, 16, 24, 32, 40, 48, 56, 64, 80, 96, 112, 128, 144, 160, 0] !! fromIntegral bitrateBits
else 0 -- Free bitrate or invalid
channels' = if channelMode == 3 then 1 else 2
in emptyAudioProperties
{ sampleRate = Just sampleRate'
, channels = Just channels'
, bitrate = if bitrate' > 0 then Just bitrate' else Nothing
, codec = Just CodecMP3
}
-- | Parse VBR headers (Xing/Info or VBRI)
parseVBRHeaders :: Handle -> AudioProperties -> IO AudioProperties
parseVBRHeaders handle props = do
-- Read frame header + side info
frameData <- BS.hGet handle 200 -- Should be enough for frame header + VBR headers
if BS.length frameData < 40
then return props
else do
-- The Xing/Info header sits after the side info, whose size depends
-- on MPEG version and channel mode: MPEG1 32/17 bytes (stereo/mono),
-- MPEG2/2.5 17/9 bytes, plus the 4-byte frame header
let versionBits = (BS.index frameData 1 `shiftR` 3) .&. 0x03
isMpeg1 = versionBits == 3
numChannels = fromMaybe 2 (channels props)
xingOffset = case (isMpeg1, numChannels == 1) of
(True, True) -> 21
(True, False) -> 36
(False, True) -> 13
(False, False) -> 21
if BS.length frameData > xingOffset + 12
then do
let xingHeader = BS.take 4 $ BS.drop xingOffset frameData
if xingHeader `elem` ["Xing", "Info"]
then parseXingHeader (BS.drop (xingOffset + 4) frameData) props handle
else
-- Check for VBRI header (always at offset 36)
if BS.length frameData > 36 + 26
then do
let vbriHeader = BS.take 4 $ BS.drop 36 frameData
if vbriHeader == "VBRI"
then parseVBRIHeader (BS.drop 40 frameData) props handle
else return props
else return props
else return props
-- | Parse Xing/Info VBR header
parseXingHeader :: BS.ByteString -> AudioProperties -> Handle -> IO AudioProperties
parseXingHeader bs props _handle = do
if BS.length bs < 8
then return props
else do
-- Only read fields the buffer actually holds; the length guard above
-- covers the flags but not both optional counters
let word32At off
| BS.length bs >= off + 4 =
Just $ runGet getWord32be (L.fromStrict $ BS.take 4 $ BS.drop off bs)
| otherwise = Nothing
flags = fromMaybe 0 (word32At 0)
hasFrames = (flags .&. 0x01) /= 0
hasBytes = (flags .&. 0x02) /= 0
-- Parse frame count and byte count if present
let offset1 = 4
(frameCount, offset2) = if hasFrames
then (word32At offset1, offset1 + 4)
else (Nothing, offset1)
(byteCount, _) = if hasBytes
then (word32At offset2, offset2 + 4)
else (Nothing, offset2)
-- Calculate average bitrate and duration for VBR
case (frameCount, byteCount, sampleRate props) of
(Just frames, Just bytes, Just sr) -> do
-- MP3 frame is 1152 samples for Layer III
let durationSecs = (fromIntegral frames * 1152) / fromIntegral sr :: Double
durationMs = round (durationSecs * 1000) :: Int -- Convert to milliseconds
avgBitrate = if durationSecs > 0
then round $ (fromIntegral bytes * 8) / durationSecs / 1000
else 0
return props { bitrate = if avgBitrate > 0 then Just avgBitrate else bitrate props
, duration = if durationMs > 0 then Just durationMs else duration props }
_ -> return props
-- | Parse VBRI VBR header
parseVBRIHeader :: BS.ByteString -> AudioProperties -> Handle -> IO AudioProperties
parseVBRIHeader bs props _handle = do
if BS.length bs < 22
then return props
else do
-- fileSize <- hFileSize _handle
let _version = runGet getWord16be (L.fromStrict $ BS.take 2 bs)
-- Skip delay and quality (2 + 2 bytes)
bytes = runGet getWord32be (L.fromStrict $ BS.take 4 $ BS.drop 6 bs)
frames = runGet getWord32be (L.fromStrict $ BS.take 4 $ BS.drop 10 bs)
-- Calculate average bitrate and duration
case sampleRate props of
Just sr -> do
let durationSecs = (fromIntegral frames * 1152) / fromIntegral sr :: Double
durationMs = round (durationSecs * 1000) :: Int -- Convert to milliseconds
avgBitrate = if durationSecs > 0
then round $ (fromIntegral bytes * 8) / durationSecs / 1000
else 0
return props { bitrate = if avgBitrate > 0 then Just avgBitrate else bitrate props
, duration = if durationMs > 0 then Just durationMs else duration props }
_ -> return props
-- | Find and parse APIC frame info in ID3v2 tag data (metadata only, no image data)
findAndParseAPICInfo :: Word8 -> L.ByteString -> Maybe AlbumArtInfo
findAndParseAPICInfo version bs
| version < 3 = Nothing -- APIC only in ID3v2.3+
| otherwise = go bs
where
go bytes
| L.length bytes < 10 = Nothing
| otherwise =
case runGetOrFail (findAPICFrame version) bytes of
Left _ -> Nothing
Right (_, _, Just pic) -> Just pic
Right (rest, consumed, Nothing)
| consumed == 0 -> Nothing -- No bytes consumed, stop to avoid infinite loop
| otherwise -> go rest
findAPICFrame :: Word8 -> Get (Maybe AlbumArtInfo)
findAPICFrame _version = do
frameId <- lookAhead $ getByteString 4
if frameId == "APIC"
then do
-- Parse the APIC frame
_ <- getByteString 4 -- Consume frame ID
frameSize <- if version >= 4
then do
b1 <- getWord8
b2 <- getWord8
b3 <- getWord8
b4 <- getWord8
return $ (fromIntegral b1 `shiftL` 21) .|.
(fromIntegral b2 `shiftL` 14) .|.
(fromIntegral b3 `shiftL` 7) .|.
fromIntegral b4
else getWord32be
_ <- getWord16be -- Skip flags
frameData <- getByteString (fromIntegral frameSize)
return $ parseAPICFrameInfo frameData
else if BS.all (== 0) frameId
then return Nothing -- Padding reached
else do
-- Skip this frame
_ <- getByteString 4
frameSize <- if version >= 4
then do
b1 <- getWord8
b2 <- getWord8
b3 <- getWord8
b4 <- getWord8
return $ (fromIntegral b1 `shiftL` 21) .|.
(fromIntegral b2 `shiftL` 14) .|.
(fromIntegral b3 `shiftL` 7) .|.
fromIntegral b4
else getWord32be
_ <- getWord16be
skip (fromIntegral frameSize)
return Nothing
-- | Parse APIC (Attached Picture) frame info (metadata only, not image data for performance)
parseAPICFrameInfo :: BS.ByteString -> Maybe AlbumArtInfo
parseAPICFrameInfo bs =
if BS.null bs
then Nothing
else
let _encoding = BS.head bs
rest = BS.tail bs
in case BS.breakSubstring "\0" rest of
(mimeType, afterMime) ->
if BS.null afterMime
then Nothing
else
let rest2 = BS.drop 1 afterMime -- Skip null terminator
pictureType = if BS.null rest2 then 0 else BS.head rest2
rest3 = if BS.null rest2 then BS.empty else BS.tail rest2
in case BS.breakSubstring "\0" rest3 of
(description, afterDesc) ->
if BS.null afterDesc
then Nothing
else
-- Don't read image data, just calculate its size
let imageDataSize = BS.length (BS.drop 1 afterDesc)
in Just $ AlbumArtInfo
{ albumArtInfoMimeType = TE.decodeUtf8With TEE.lenientDecode mimeType
, albumArtInfoPictureType = pictureType
, albumArtInfoDescription = TE.decodeUtf8With TEE.lenientDecode description
, albumArtInfoSizeBytes = imageDataSize
}
-- | Load album art from MP3 file (full binary data for writing)
loadAlbumArtMP3 :: OsPath -> Parser (Maybe AlbumArt)
loadAlbumArtMP3 filePath = do
result <- liftIO $ withBinaryFile filePath ReadMode $ \handle -> do
-- Parse ID3v2 tag at beginning if present
hSeek handle AbsoluteSeek 0
header <- BS.hGet handle 10
if BS.length header < 10 || BS.take 3 header /= id3v2Signature
then return $ Right Nothing -- No ID3v2 tag
else do
-- Parse header to get tag size
let version = BS.index header 3
size = parseSynchsafeInt (BS.drop 6 header)
-- Read only the ID3v2 tag data
tagData <- BS.hGet handle (fromIntegral size)
-- Find and parse APIC frame with full data
return $ Right $ findAndParseAPICFull version (L.fromStrict tagData)
case result of
Left err -> throwError err
Right maybeArt -> return maybeArt
where
findAndParseAPICFull :: Word8 -> L.ByteString -> Maybe AlbumArt
findAndParseAPICFull version bs
| version < 3 = Nothing -- APIC only in ID3v2.3+
| otherwise = go bs
where
go bytes
| L.length bytes < 10 = Nothing
| otherwise =
case runGetOrFail (findAPICFrame version) bytes of
Left _ -> Nothing
Right (_, _, Just pic) -> Just pic
Right (rest, consumed, Nothing)
| consumed == 0 -> Nothing
| otherwise -> go rest
findAPICFrame :: Word8 -> Get (Maybe AlbumArt)
findAPICFrame _version = do
frameId <- lookAhead $ getByteString 4
if frameId == "APIC"
then do
_ <- getByteString 4 -- Consume frame ID
frameSize <- if version >= 4
then do
b1 <- getWord8
b2 <- getWord8
b3 <- getWord8
b4 <- getWord8
return $ (fromIntegral b1 `shiftL` 21) .|.
(fromIntegral b2 `shiftL` 14) .|.
(fromIntegral b3 `shiftL` 7) .|.
fromIntegral b4
else getWord32be
_ <- getWord16be -- Skip flags
frameData <- getByteString (fromIntegral frameSize)
return $ parseAPICFrameFull frameData
else if BS.all (== 0) frameId
then return Nothing
else do
_ <- getByteString 4
frameSize <- if version >= 4
then do
b1 <- getWord8
b2 <- getWord8
b3 <- getWord8
b4 <- getWord8
return $ (fromIntegral b1 `shiftL` 21) .|.
(fromIntegral b2 `shiftL` 14) .|.
(fromIntegral b3 `shiftL` 7) .|.
fromIntegral b4
else getWord32be
_ <- getWord16be
skip (fromIntegral frameSize)
return Nothing
parseAPICFrameFull :: BS.ByteString -> Maybe AlbumArt
parseAPICFrameFull bs =
if BS.null bs
then Nothing
else
let _encoding = BS.head bs
rest = BS.tail bs
in case BS.breakSubstring "\0" rest of
(mimeType, afterMime) ->
if BS.null afterMime
then Nothing
else
let rest2 = BS.drop 1 afterMime
pictureType = if BS.null rest2 then 0 else BS.head rest2
rest3 = if BS.null rest2 then BS.empty else BS.tail rest2
in case BS.breakSubstring "\0" rest3 of
(description, afterDesc) ->
if BS.null afterDesc
then Nothing
else
let imageData = BS.drop 1 afterDesc
in Just $ AlbumArt
{ albumArtMimeType = TE.decodeUtf8With TEE.lenientDecode mimeType
, albumArtPictureType = pictureType
, albumArtDescription = TE.decodeUtf8With TEE.lenientDecode description
, albumArtData = imageData
}
-- | Extract year from TDRC date field (YYYY-MM-DD or just YYYY)
extractYearFromDate :: T.Text -> Maybe Int
extractYearFromDate dateText =
let yearStr = T.takeWhile (/= '-') dateText
in readInt yearStr