diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,16 @@ # Changelog for `monatone` +## [0.4.0.1] - 2026-07-25 + +### Fixed +- M4A updates carry unknown typed and binary ilst atoms (tmpo, cpil, + binary freeform data) over verbatim instead of dropping them; text + tags keep round-tripping through `rawTags` so edits there still win +- FLAC files with an ID3v2 tag prepended by other tools are detected as + FLAC rather than MP3, parse correctly, and updates strip the stale tag +- CI: a checked-in `cabal.project` with `tests: True` forces the solver + to include the test suite, fixing `cabal test` failures on CI + ## [0.4.0.0] - 2026-07-24 ### Added diff --git a/monatone.cabal b/monatone.cabal --- a/monatone.cabal +++ b/monatone.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: monatone -version: 0.4.0.0 +version: 0.4.0.1 synopsis: Pure Haskell library for audio metadata parsing and writing description: Monatone is a pure Haskell library for parsing and writing diff --git a/src/Monatone/Common.hs b/src/Monatone/Common.hs --- a/src/Monatone/Common.hs +++ b/src/Monatone/Common.hs @@ -11,7 +11,7 @@ import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import System.IO (IOMode(..)) +import System.IO (Handle, IOMode(..), hSeek, SeekMode(..)) import System.OsPath import System.File.OsPath (withBinaryFile) @@ -57,12 +57,28 @@ let ftypSig = BS.take 4 $ BS.drop 4 bs in ftypSig == "ftyp" +-- | Detect a file's format from its content. An ID3v2 tag is not proof of +-- MP3 - some taggers prepend one to FLAC files - so when a file starts with +-- ID3 the detection looks at what actually follows the tag chain. +sniffFormat :: OsPath -> IO (Maybe AudioFormat) +sniffFormat filePath = withBinaryFile filePath ReadMode $ \h -> do + header <- BS.hGet h 12 + case detectFormat header of + Just MP3 | BS.isPrefixOf "ID3" header -> resolveAfterID3 h + other -> return other + where + resolveAfterID3 :: Handle -> IO (Maybe AudioFormat) + resolveAfterID3 h = do + offset <- FLAC.skipLeadingID3 h + hSeek h AbsoluteSeek offset + sig <- BS.hGet h 4 + return $ Just $ if sig == "fLaC" then FLAC else MP3 + -- | Parse metadata from file parseMetadata :: OsPath -> IO (Either ParseError Metadata) parseMetadata filePath = do - -- Only read first 12 bytes for format detection - header <- withBinaryFile filePath ReadMode $ \h -> BS.hGet h 12 - case detectFormat header of + detected <- sniffFormat filePath + case detected of Nothing -> return $ Left $ UnsupportedFormat "Unknown audio format" Just fmt -> runExceptT $ case fmt of FLAC -> FLAC.parseFLAC filePath @@ -75,9 +91,8 @@ -- This reads only the album art data, not all metadata loadAlbumArt :: OsPath -> IO (Either ParseError (Maybe AlbumArt)) loadAlbumArt filePath = do - -- Only read first 12 bytes for format detection - header <- withBinaryFile filePath ReadMode $ \h -> BS.hGet h 12 - case detectFormat header of + detected <- sniffFormat filePath + case detected of Nothing -> return $ Left $ UnsupportedFormat "Unknown audio format" Just fmt -> runExceptT $ case fmt of FLAC -> FLAC.loadAlbumArtFLAC filePath diff --git a/src/Monatone/FLAC.hs b/src/Monatone/FLAC.hs --- a/src/Monatone/FLAC.hs +++ b/src/Monatone/FLAC.hs @@ -5,6 +5,7 @@ ( parseFLAC , parseVorbisComments , loadAlbumArtFLAC + , skipLeadingID3 ) where import Control.Applicative ((<|>)) @@ -62,11 +63,31 @@ , blockLength :: Word32 } deriving (Show, Eq) +-- | Skip any ID3v2 tags prepended to the file. FLAC files should not carry +-- ID3, but some taggers add one anyway; returns the offset of the first +-- byte past the tag chain (0 when there is none). +skipLeadingID3 :: Handle -> IO Integer +skipLeadingID3 handle = go 0 + where + go offset = do + hSeek handle AbsoluteSeek offset + header <- BS.hGet handle 10 + if BS.length header < 10 || BS.take 3 header /= "ID3" + then return offset + else do + let sync i = fromIntegral (BS.index header i .&. 0x7F) :: Integer + size = (sync 6 `shiftL` 21) .|. (sync 7 `shiftL` 14) + .|. (sync 8 `shiftL` 7) .|. sync 9 + footer = if BS.index header 5 .&. 0x10 /= 0 then 10 else 0 + go (offset + 10 + size + footer) + -- | Parse FLAC file efficiently - only read metadata blocks, not entire file parseFLAC :: OsPath -> Parser Metadata parseFLAC filePath = do metadata <- liftIO $ withBinaryFile filePath ReadMode $ \handle -> do - -- Read and verify FLAC signature (4 bytes) + -- Tolerate ID3v2 tags other tools prepended before the signature + start <- skipLeadingID3 handle + hSeek handle AbsoluteSeek start sig <- BS.hGet handle 4 if sig /= flacSignature then return $ Left $ CorruptedFile "Invalid FLAC signature" @@ -323,7 +344,9 @@ loadAlbumArtFLAC :: OsPath -> Parser (Maybe AlbumArt) loadAlbumArtFLAC filePath = do result <- liftIO $ withBinaryFile filePath ReadMode $ \handle -> do - -- Read and verify FLAC signature (4 bytes) + -- Tolerate ID3v2 tags other tools prepended before the signature + start <- skipLeadingID3 handle + hSeek handle AbsoluteSeek start sig <- BS.hGet handle 4 if sig /= flacSignature then return $ Left $ CorruptedFile "Invalid FLAC signature" diff --git a/src/Monatone/FLAC/Writer.hs b/src/Monatone/FLAC/Writer.hs --- a/src/Monatone/FLAC/Writer.hs +++ b/src/Monatone/FLAC/Writer.hs @@ -31,6 +31,7 @@ import System.File.OsPath (withBinaryFile) import Monatone.Metadata +import Monatone.FLAC (skipLeadingID3) import Paths_monatone (version) import Data.Version (showVersion) @@ -65,6 +66,13 @@ -- | Write FLAC metadata using a file handle incrementally writeFLACHandleIncremental :: Metadata -> AlbumArtUpdate -> Handle -> Writer () writeFLACHandleIncremental metadata artUpdate handle = do + -- Strip any ID3v2 tags other tools prepended to the signature: they hold + -- stale copies of the tags this update replaces + junkLength <- liftIO $ skipLeadingID3 handle + if junkLength > 0 + then deleteBytesInFile handle (fromIntegral junkLength) 0 + else pure () + -- Verify FLAC signature liftIO $ hSeek handle AbsoluteSeek 0 sig <- liftIO $ BS.hGet handle 4 diff --git a/src/Monatone/M4A.hs b/src/Monatone/M4A.hs --- a/src/Monatone/M4A.hs +++ b/src/Monatone/M4A.hs @@ -264,7 +264,15 @@ -- Atom names use Latin-1 encoding (©nam is 0xA9 0x6E 0x61 0x6D) key = TE.decodeLatin1 tagName - current = if not (T.null value) then [(key, value)] else [] + -- The writer re-emits \169/---- rawTags entries as UTF-8 text, + -- so only genuinely textual payloads may land there for those + -- keys; non-text payloads are instead carried over verbatim at + -- write time. Other atoms (tmpo, gnre, ...) are also carried + -- verbatim, so their decoded view here is informational only. + isTextType = dataType == 1 || dataType == 2 + reEmittable = BS.isPrefixOf "\169" tagName || BS.isPrefixOf "----:" tagName + keep = not (T.null value) && (isTextType || not reEmittable) + current = if keep then [(key, value)] else [] next = if BS.length rest >= 16 then parseDataAtoms tagName rest else [] in current ++ next diff --git a/src/Monatone/M4A/Writer.hs b/src/Monatone/M4A/Writer.hs --- a/src/Monatone/M4A/Writer.hs +++ b/src/Monatone/M4A/Writer.hs @@ -22,6 +22,7 @@ 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 Data.Word import System.IO hiding (withBinaryFile) import System.OsPath @@ -166,12 +167,11 @@ hSeek srcHandle AbsoluteSeek moovOffset moovData <- BS.hGet srcHandle (fromIntegral moovSize) - -- When keeping existing art, carry the covr atom(s) from the old - -- ilst over verbatim - let keptCovr = case artUpdate of - KeepExistingArt -> extractCovrAtoms (BS.drop 8 moovData) - _ -> L.empty - fullIlstData = newIlstData <> keptCovr + -- Carry over verbatim every old ilst atom the rewrite does not own: + -- unknown typed/binary atoms, and the covr atom(s) when the art is + -- unchanged + let preserved = extractPreservedIlstAtoms artUpdate (BS.drop 8 moovData) + fullIlstData = newIlstData <> preserved -- Rebuild moov with new ilst, then fix up chunk offsets: stco/co64 -- entries are absolute file positions, and resizing moov moves every @@ -184,40 +184,77 @@ -- Copy all atoms after moov liftIO $ copyAfterMoov srcHandle dstHandle moovOffset moovSize --- | Extract the raw covr atom(s) from a moov atom's content by walking --- udta > meta (skipping its version/flags) > ilst -extractCovrAtoms :: ByteString -> L.ByteString -extractCovrAtoms moovContent = +-- | Extract from a moov atom's content (walking udta > meta, skipping its +-- version/flags, > ilst) the raw bytes of every ilst atom that must be +-- carried over verbatim: typed atoms the mapped fields do not own (tmpo, +-- cpil, ...), \169/---- atoms whose payload is not text - rawTags cannot +-- represent those faithfully - and, when the art is unchanged, the covr +-- atom(s). Text-representable \169/---- tags are excluded: they round-trip +-- through rawTags instead so edits made there win over the file contents. +extractPreservedIlstAtoms :: AlbumArtUpdate -> ByteString -> L.ByteString +extractPreservedIlstAtoms artUpdate moovContent = case findChildAtom "udta" moovContent of Nothing -> L.empty Just udtaContent -> case findChildAtom "meta" udtaContent of Nothing -> L.empty Just metaContent -> case findChildAtom "ilst" (BS.drop 4 metaContent) of Nothing -> L.empty - Just ilstContent -> L.fromStrict $ BS.concat (collectAtoms "covr" ilstContent) + Just ilstContent -> L.fromStrict $ BS.concat + [ raw | (name, raw, content) <- walkAtoms ilstContent + , keepVerbatim name content ] where - -- Walk sibling atoms; return the named atom's content - findChildAtom name bs = listToMaybe [c | (n, _, c) <- walkAtoms bs, n == name] + keepVerbatim name content + | name == "covr" = artUpdate == KeepExistingArt + | name `elem` regenerated = False + | name == "----" = case freeformKey content of + Just key | key `elem` handledFreeform -> False + Just _ -> not (textRepresentable content) + -- Malformed mean/name: the reader skipped it, keep the bytes + Nothing -> True + | BS.isPrefixOf "\169" name = not (textRepresentable content) + | otherwise = True - -- Walk sibling atoms; return the named atoms verbatim (with header) - collectAtoms name bs = [raw | (n, raw, _) <- walkAtoms bs, n == name] + -- Atoms rebuilt from mapped fields on every write + regenerated = handledAtomNames ++ ["trkn", "disk"] - walkAtoms bs - | BS.length bs < 8 = [] - | otherwise = - let size32 = readWord32BE $ BS.take 4 bs - name = BS.take 4 $ BS.drop 4 bs - (headerLen, atomSize) - | size32 == 0 = (8, BS.length bs) -- atom extends to end - | size32 == 1 && BS.length bs >= 16 = - (16, fromIntegral $ readWord64BE $ BS.take 8 $ BS.drop 8 bs) - | otherwise = (8, fromIntegral size32) - in if atomSize < headerLen || atomSize > BS.length bs - then [] -- corrupt size; stop walking - else - let (atom, rest) = BS.splitAt atomSize bs - in (name, atom, BS.drop headerLen atom) : walkAtoms rest + -- Every data child carries text: the reader put the values in rawTags + -- and generateIlstData writes them back from there + textRepresentable content = + let types = [ readWord32BE (BS.take 4 c) + | (n, _, c) <- walkAtoms content, n == "data", BS.length c >= 4 ] + in not (null types) && all (`elem` [1, 2 :: Word32]) types + freeformKey content = do + meanContent <- findChildAtom "mean" content + nameContent <- findChildAtom "name" content + return $ "----:" <> decodeAfterFlags meanContent + <> ":" <> decodeAfterFlags nameContent + + -- mean/name payloads start with a 4-byte version/flags field + decodeAfterFlags = TE.decodeUtf8With TEE.lenientDecode . BS.drop 4 + +-- | Walk sibling atoms; return the named atom's content +findChildAtom :: ByteString -> ByteString -> Maybe ByteString +findChildAtom name bs = listToMaybe [c | (n, _, c) <- walkAtoms bs, n == name] + +-- | Walk sibling atoms as (name, raw atom with header, content) triples +walkAtoms :: ByteString -> [(ByteString, ByteString, ByteString)] +walkAtoms bs + | BS.length bs < 8 = [] + | otherwise = + let size32 = readWord32BE $ BS.take 4 bs + name = BS.take 4 $ BS.drop 4 bs + (headerLen, atomSize) + | size32 == 0 = (8, BS.length bs) -- atom extends to end + | size32 == 1 && BS.length bs >= 16 = + (16, fromIntegral $ readWord64BE $ BS.take 8 $ BS.drop 8 bs) + | otherwise = (8, fromIntegral size32) + in if atomSize < headerLen || atomSize > BS.length bs + then [] -- corrupt size; stop walking + else + let (atom, rest) = BS.splitAt atomSize bs + in (name, atom, BS.drop headerLen atom) : walkAtoms rest + -- | Copy atoms before moov copyBeforeMoov :: Handle -> Handle -> [AtomInfo] -> Integer -> IO () copyBeforeMoov srcHandle dstHandle atoms moovOffset = do @@ -359,10 +396,35 @@ then go nextRemaining acc -- Skip udta atom else go nextRemaining (acc <> atomData) -- Keep other atoms --- | Generate ilst atom data with all tags +-- | Atoms the mapped fields own (whether or not they are set right now): +-- stale rawTags copies of these must not be written back, and the old ilst +-- copies are never carried over verbatim +handledAtomNames :: [ByteString] +handledAtomNames = + [ "\169nam", "\169ART", "\169alb", "aART", "\169day", "\169gen" + , "\169cmt", "\169pub" + ] + +handledAtoms :: [Text] +handledAtoms = map TE.decodeLatin1 handledAtomNames + +-- | Freeform keys the mapped fields own +handledFreeform :: [Text] +handledFreeform = map ("----:com.apple.iTunes:" <>) + [ "LABEL", "CATALOGNUMBER", "BARCODE" + , "MusicBrainz Album Release Country", "MusicBrainz Album Status" + , "MusicBrainz Album Type" + , "MusicBrainz Release Track Id", "MusicBrainz Track Id" + , "MusicBrainz Album Id", "MusicBrainz Release Group Id" + , "MusicBrainz Artist Id", "MusicBrainz Album Artist Id" + , "MusicBrainz Work Id", "MusicBrainz Disc Id" + , "Acoustid Fingerprint", "Acoustid Id" + ] + -- | Generate ilst atom data with all tags. Every field the M4A parser maps --- is written back, and unmapped atoms in rawTags are carried over so an --- update never drops tags it does not understand. +-- is written back, and unmapped text tags in rawTags are re-emitted so an +-- update never drops tags it does not understand (atoms rawTags cannot +-- represent are carried over verbatim by the moov rewrite instead). generateIlstData :: Metadata -> AlbumArtUpdate -> Writer L.ByteString generateIlstData metadata artUpdate = do let tags = concat @@ -413,28 +475,10 @@ , renderFreeformTag "MusicBrainz Disc Id" <$> maybeToList (mbDiscId mbids) ] - -- Atoms the mapped fields own (whether or not they are set right now): - -- stale rawTags copies of these must not be written back - handledAtoms = - [ "\169nam", "\169ART", "\169alb", "aART", "\169day", "\169gen" - , "\169cmt", "\169pub" - ] :: [Text] - - handledFreeform = map ("----:com.apple.iTunes:" <>) - [ "LABEL", "CATALOGNUMBER", "BARCODE" - , "MusicBrainz Album Release Country", "MusicBrainz Album Status" - , "MusicBrainz Album Type" - , "MusicBrainz Release Track Id", "MusicBrainz Track Id" - , "MusicBrainz Album Id", "MusicBrainz Release Group Id" - , "MusicBrainz Artist Id", "MusicBrainz Album Artist Id" - , "MusicBrainz Work Id", "MusicBrainz Disc Id" - , "Acoustid Fingerprint", "Acoustid Id" - ] :: [Text] - - -- rawTags only holds text-decoded values, so preservation is limited to - -- tags that can be reproduced faithfully from text: \169-prefixed text - -- atoms and freeform (----) tags. Typed atoms (trkn, disk, covr, tmpo, - -- ...) are either regenerated from mapped fields or skipped + -- Text-representable \169/---- tags are written back from rawTags so + -- edits there take effect; everything else the mapped fields do not own + -- (typed atoms, binary payloads) is carried over verbatim from the old + -- ilst by extractPreservedIlstAtoms instead renderPreservedTag :: Text -> Text -> [L.ByteString] renderPreservedTag key value | key `elem` handledAtoms || key `elem` handledFreeform = [] diff --git a/test/Test/IntegrationSpec.hs b/test/Test/IntegrationSpec.hs --- a/test/Test/IntegrationSpec.hs +++ b/test/Test/IntegrationSpec.hs @@ -88,6 +88,8 @@ [ testFLACMultiPicture , testMP3BinaryFrames , testM4ACovrPreservation + , testM4ABinaryAtoms + , testFLACLeadingID3 ] , testGroup "Tag Preservation" [ testTagPreservation "MP3" "minimal.mp3" @@ -202,6 +204,79 @@ >>= either (assertFailure . show) return afterRemove <- BS.readFile path assertBool "cover art removed" (not (img `BS.isInfixOf` afterRemove)) + removeFile path + +-- | Typed and binary ilst atoms the writer does not map (tmpo, cpil, a +-- binary freeform payload) survive an update byte-for-byte, exactly once +testM4ABinaryAtoms :: TestTree +testM4ABinaryAtoms = testCase "M4A keeps unknown binary atoms through updates" $ do + let dataAtom dtype payload = + w32 (16 + BS.length payload) <> "data" <> w32 dtype <> w32 0 <> payload + tmpoAtom = atomBS "tmpo" (dataAtom 21 (BS.pack [0x00, 0x78])) + cpilAtom = atomBS "cpil" (dataAtom 21 (BS.pack [0x01])) + binParams = BS.pack [0x76, 0x65, 0x72, 0x73, 0, 0, 0, 1, 0xDE, 0xAD, 0xBE, 0xEF] + freeformAtom = atomBS "----" $ + atomBS "mean" (w32 0 <> "com.apple.iTunes") + <> atomBS "name" (w32 0 <> "Encoding Params") + <> dataAtom 0 binParams + ilst = atomBS "\169nam" (dataAtom 1 "Old") + <> tmpoAtom <> cpilAtom <> freeformAtom + moov = atomBS "moov" $ atomBS "udta" $ atomBS "meta" (w32 0 <> atomBS "ilst" ilst) + bytes = atomBS "ftyp" ("M4A " <> w32 0) <> moov <> atomBS "mdat" (BS.replicate 16 0xCC) + path <- writeMalformed "monatone-binatoms.m4a" bytes + osPath <- toOsPath path + + runExceptT (updateMetadata osPath (setTitle "New" emptyUpdate)) + >>= either (assertFailure . show) return + after <- BS.readFile path + assertEqual "tmpo kept once, verbatim" 1 (countSub tmpoAtom after) + assertEqual "cpil kept once, verbatim" 1 (countSub cpilAtom after) + assertEqual "binary freeform kept once, verbatim" 1 (countSub freeformAtom after) + + final <- parseMetadata osPath >>= either (assertFailure . show) return + assertEqual "title updated" (Just "New") (title final) + assertEqual "tmpo still readable" (Just ["120"]) (HM.lookup "tmpo" (rawTags final)) + removeFile path + +-- | Count non-overlapping occurrences of a byte pattern +countSub :: BS.ByteString -> BS.ByteString -> Int +countSub pat = go 0 + where + go n haystack = case BS.breakSubstring pat haystack of + (_, rest) + | BS.null rest -> n + | otherwise -> go (n + 1) (BS.drop (BS.length pat) rest) + +-- | An ID3v2 tag prepended to a FLAC file must not route it to the MP3 +-- parser, and an update strips the stale tag +testFLACLeadingID3 :: TestTree +testFLACLeadingID3 = testCase "FLAC with leading ID3v2 tag parses and updates" $ do + let staleId3 = id3v24Tag [frame24 "TIT2" (BS.singleton 3 <> "Stale")] + w32le n = BS.pack [fromIntegral (n `shiftR` s) | s <- [0, 8, 16, 24 :: Int]] + vorbisComment t = w32le (BS.length t) <> t + vorbis = w32le (0 :: Int) <> w32le (1 :: Int) <> vorbisComment "TITLE=Old" + block btype content = + BS.pack [btype, 0, 0, fromIntegral (BS.length content)] <> content + markLast bs = BS.cons (BS.head bs .|. 0x80) (BS.tail bs) + bytes = staleId3 + <> "fLaC" + <> block 0 (BS.replicate 34 0) + <> markLast (block 4 vorbis) + <> "AUDIODATA" + path <- writeMalformed "monatone-leading-id3.flac" bytes + osPath <- toOsPath path + + before <- parseMetadata osPath >>= either (assertFailure . show) return + assertEqual "detected as FLAC" FLAC (format before) + assertEqual "vorbis title read, not the stale ID3 one" (Just "Old") (title before) + + runExceptT (updateMetadata osPath (setTitle "New" emptyUpdate)) + >>= either (assertFailure . show) return + after <- BS.readFile path + assertBool "stale ID3 stripped" (BS.isPrefixOf "fLaC" after) + assertBool "audio intact" ("AUDIODATA" `BS.isSuffixOf` after) + final <- parseMetadata osPath >>= either (assertFailure . show) return + assertEqual "title updated" (Just "New") (title final) removeFile path -- | Walk the metadata blocks of a FLAC file: (type, content) pairs