monatone 0.4.0.0 → 0.4.0.1

raw patch · 8 files changed

+250/−66 lines, 8 filesPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• monatone.cabal +1/−1
• src/Monatone/Common.hs +22/−7
• src/Monatone/FLAC.hs +25/−2
• src/Monatone/FLAC/Writer.hs +8/−0
• src/Monatone/M4A.hs +9/−1
• src/Monatone/M4A/Writer.hs +99/−55
• test/Test/IntegrationSpec.hs +75/−0

@@ -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

@@ -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

@@ -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

@@ -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"

@@ -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

@@ -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 

@@ -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 = []

@@ -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