diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,34 @@ # Changelog for `monatone` +## [0.3.0.0] - 2026-07-20 + +### Fixed +- **M4A writer corrupted moov-first ("fast start") files**: stco/co64 chunk + offsets are now adjusted when the moov atom changes size, so audio stays + playable after a tag update +- M4A writer no longer silently discards errors from the file rewrite +- **Writes are now atomic**: metadata is written to a temporary sibling file + which is renamed over the original, so a failed write or crash can no + longer corrupt or truncate the audio file +- **Updates no longer drop tags the writer does not map**: MusicBrainz IDs + and AcoustID tags (MP3), track/disc totals (MP3, FLAC), release + status/type (M4A), unmapped ID3 text/TXXX frames, Vorbis comments, and + iTunes text/freeform atoms are all preserved across updates +- FLAC updates preserve SEEKTABLE, APPLICATION, CUESHEET and unknown + metadata blocks instead of discarding them +- Single date field per file: `setYear` no longer produces duplicate + TDRC frames (MP3) or DATE comments (FLAC) +- FLAC comment values containing `=` are no longer truncated +- MP3 parser now reads disc number and track/disc totals from TRCK/TPOS +- FLAC parser now populates `rawTags`; M4A parser now reads release + status/type +- FLAC vendor string now tracks the package version automatically + +### Changed +- **Breaking**: removed `writeMetadataToFile` from `Monatone.Writer`; use + `writeMetadata`, which is now atomic and no longer needs the `.backup` + mechanism + ## [0.2.1.1] - 2025-12-10 ### Fixed diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -58,6 +58,7 @@ , "sampleRate" .= sampleRate props , "channels" .= channels props , "bitsPerSample" .= bitsPerSample props + , "codec" .= codec props ] instance ToJSON MusicBrainzIds where @@ -113,6 +114,15 @@ exitFailure -- | Format track or disc info with total if available +-- | Human-readable codec name for display +codecName :: Codec -> Text +codecName CodecFLAC = "FLAC" +codecName CodecMP3 = "MP3" +codecName CodecVorbis = "Vorbis" +codecName CodecOpus = "Opus" +codecName CodecAAC = "AAC" +codecName CodecALAC = "ALAC" + formatTrackInfo :: Maybe Int -> Maybe Int -> Text formatTrackInfo Nothing _ = "null" formatTrackInfo (Just num) Nothing = T.pack $ show num @@ -146,6 +156,7 @@ putStrLn $ T.unpack $ " Sample Rate: " <> maybe "null" (\s -> T.pack (show s) <> "Hz") (sampleRate props) putStrLn $ T.unpack $ " Channels: " <> maybe "null" (T.pack . show) (channels props) putStrLn $ T.unpack $ " Bits Per Sample: " <> maybe "null" (T.pack . show) (bitsPerSample props) + putStrLn $ T.unpack $ " Codec: " <> maybe "null" codecName (codec props) putStrLn "\nMusicBrainz IDs:" let mbIds = musicBrainzIds metadata 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.2.1.1 +version: 0.3.0.0 synopsis: Pure Haskell library for audio metadata parsing and writing description: Monatone is a pure Haskell library for parsing and writing @@ -50,6 +50,10 @@ Monatone.OGG Monatone.Types Monatone.Writer + other-modules: + Paths_monatone + autogen-modules: + Paths_monatone hs-source-dirs: src build-depends: @@ -130,7 +134,8 @@ tasty-hunit >= 0.10 && < 0.11, tasty-quickcheck >= 0.11 && < 0.12, temporary, - text + text, + unordered-containers default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Monatone/FLAC.hs b/src/Monatone/FLAC.hs --- a/src/Monatone/FLAC.hs +++ b/src/Monatone/FLAC.hs @@ -182,6 +182,7 @@ , bitsPerSample = Just bitsPerSample' , bitrate = Nothing -- Will be calculated later if needed , duration = duration' + , codec = Just CodecFLAC } } where @@ -257,6 +258,7 @@ HM.lookup "acoustid_fingerprint" tagMap , acoustidId = HM.lookup "ACOUSTID_ID" tagMap <|> HM.lookup "acoustid_id" tagMap + , rawTags = tagMap } where parseCommentList :: Int -> Get [(Text, Text)] @@ -268,9 +270,9 @@ commentBytes <- getByteString (fromIntegral commentLength) -- Parse the comment (format: "KEY=value") let comment' = case BS.split 0x3D commentBytes of -- Split on '=' - (key:value:_) -> + (key:value:rest) -> let keyText = T.toUpper $ TE.decodeUtf8With TEE.lenientDecode key - valueText = TE.decodeUtf8With TEE.lenientDecode (BS.intercalate "=" (value:[])) + valueText = TE.decodeUtf8With TEE.lenientDecode (BS.intercalate "=" (value:rest)) in Just (keyText, valueText) _ -> Nothing rest <- parseCommentList (n - 1) 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 @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TupleSections #-} module Monatone.FLAC.Writer ( writeFLACMetadata @@ -8,6 +9,7 @@ , Writer ) where +import Control.Applicative ((<|>)) import Control.Exception (catch, IOException) import Control.Monad.Except (ExceptT, throwError, runExceptT) import Control.Monad.IO.Class (liftIO) @@ -16,6 +18,8 @@ import Data.Bits ((.|.), shiftL, shiftR, (.&.)) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L +import qualified Data.HashMap.Strict as HM +import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -25,6 +29,8 @@ import System.File.OsPath (withBinaryFile) import Monatone.Metadata +import Paths_monatone (version) +import Data.Version (showVersion) -- Re-define WriteError and Writer locally to avoid circular imports data WriteError @@ -70,11 +76,11 @@ streamInfoData <- liftIO $ BS.hGet handle 34 let originalStreamInfo = L.fromStrict $ BS.append streamInfoHeader streamInfoData - -- Find where the audio data starts - audioDataOffset <- findAudioDataOffsetHandle handle 4 -- Start after "fLaC" + -- Find where the audio data starts, collecting blocks we must keep verbatim + (audioDataOffset, preservedBlocks) <- scanMetadataBlocks handle 4 -- Start after "fLaC" -- Generate new metadata blocks with preserved STREAMINFO - newMetadataBlocks <- generateMetadataBlocks metadata maybeAlbumArt originalStreamInfo + newMetadataBlocks <- generateMetadataBlocks metadata maybeAlbumArt originalStreamInfo preservedBlocks let newMetadataSize = fromIntegral $ L.length newMetadataBlocks -- Get file size @@ -106,25 +112,34 @@ -- Then delete extra space deleteBytesInFile handle bytesToDelete (4 + newMetadataSize) --- | Find where audio data starts by parsing metadata blocks -findAudioDataOffsetHandle :: Handle -> Int -> Writer Int -findAudioDataOffsetHandle handle currentOffset = do - -- Seek to current position - liftIO $ hSeek handle AbsoluteSeek (fromIntegral currentOffset) - - -- Read block header (4 bytes) - headerBytes <- liftIO $ BS.hGet handle 4 - if BS.length headerBytes < 4 then - return currentOffset - else do - let header = runGet parseBlockHeader (L.fromStrict headerBytes) - let blockSize = fromIntegral (blockLength header) - let nextOffset = currentOffset + 4 + blockSize - - if isLast header - then return nextOffset -- This was the last metadata block - else findAudioDataOffsetHandle handle nextOffset +-- | Walk the metadata blocks: return the audio data offset plus the raw +-- bytes of every block we must carry over verbatim (SEEKTABLE, APPLICATION, +-- CUESHEET, unknown types). STREAMINFO, VORBIS_COMMENT and PICTURE are +-- regenerated; PADDING is dropped. +scanMetadataBlocks :: Handle -> Int -> Writer (Int, [L.ByteString]) +scanMetadataBlocks handle startOffset = go startOffset [] + where + regenerated = [0, 1, 4, 6] -- STREAMINFO, PADDING, VORBIS_COMMENT, PICTURE + go currentOffset acc = do + liftIO $ hSeek handle AbsoluteSeek (fromIntegral currentOffset) + headerBytes <- liftIO $ BS.hGet handle 4 + if BS.length headerBytes < 4 + then return (currentOffset, reverse acc) + else do + let header = runGet parseBlockHeader (L.fromStrict headerBytes) + blockSize = fromIntegral (blockLength header) + nextOffset = currentOffset + 4 + blockSize + acc' <- if blockType header `elem` regenerated + then return acc + else do + blockData <- liftIO $ BS.hGet handle blockSize + -- Last-block flag is recomputed when the blocks are reassembled + return $ L.fromStrict (headerBytes <> blockData) : acc + if isLast header + then return (nextOffset, reverse acc') + else go nextOffset acc' + -- | Insert bytes into file at given offset insertBytesInFile :: Handle -> Int -> Int -> Writer () insertBytesInFile handle size offset = do @@ -224,42 +239,33 @@ then throwError $ CorruptedWrite "File too small for STREAMINFO block" else return $ L.take 38 blockData -- Include header + data --- | Generate new metadata blocks -generateMetadataBlocks :: Metadata -> Maybe AlbumArt -> L.ByteString -> Writer L.ByteString -generateMetadataBlocks metadata maybeAlbumArt originalStreamInfo = do - -- Generate Vorbis comment block with metadata +-- | Generate new metadata blocks: STREAMINFO, preserved blocks, Vorbis +-- comment, and optionally a Picture block, with the last-block flag set on +-- the final block only +generateMetadataBlocks :: Metadata -> Maybe AlbumArt -> L.ByteString -> [L.ByteString] -> Writer L.ByteString +generateMetadataBlocks metadata maybeAlbumArt originalStreamInfo preservedBlocks = do vorbisBlock <- generateVorbisCommentBlock metadata False - - -- Mark STREAMINFO as not-last (clear the last-block flag) - let streamInfoNotLast = case L.unpack originalStreamInfo of - (firstByte:rest) -> L.pack $ (firstByte .&. 0x7F) : rest -- Clear the 0x80 bit - _ -> originalStreamInfo - - -- Generate Picture block if album art is provided - case maybeAlbumArt of - Nothing -> do - -- Mark Vorbis comment as last block - let vorbisBlockLast = case L.unpack vorbisBlock of - (firstByte:rest) -> L.pack $ (firstByte .|. 0x80) : rest -- Set the 0x80 bit - _ -> vorbisBlock - return $ streamInfoNotLast <> vorbisBlockLast - - Just albumArt -> do - -- Generate Picture block - pictureBlock <- generatePictureBlock albumArt True + pictureBlocks <- case maybeAlbumArt of + Nothing -> return [] + Just albumArt -> (: []) <$> generatePictureBlock albumArt False - -- Mark Vorbis comment as not-last - let vorbisBlockNotLast = case L.unpack vorbisBlock of - (firstByte:rest) -> L.pack $ (firstByte .&. 0x7F) : rest -- Clear the 0x80 bit - _ -> vorbisBlock + let blocks = [originalStreamInfo] ++ preservedBlocks ++ [vorbisBlock] ++ pictureBlocks + return $ L.concat $ markLastBlock blocks + where + markLastBlock [] = [] + markLastBlock [block] = [setLastFlag True block] + markLastBlock (block:rest) = setLastFlag False block : markLastBlock rest - return $ streamInfoNotLast <> vorbisBlockNotLast <> pictureBlock + setLastFlag set block = case L.uncons block of + Just (firstByte, rest) -> + L.cons (if set then firstByte .|. 0x80 else firstByte .&. 0x7F) rest + Nothing -> block -- | Generate Vorbis comment block generateVorbisCommentBlock :: Metadata -> Bool -> Writer L.ByteString generateVorbisCommentBlock metadata isLastBlock = do -- Create vendor string - let vendor = "Monatone 0.1.0.0" + let vendor = T.pack $ "Monatone " ++ showVersion version let vendorBytes = TE.encodeUtf8 vendor let vendorLenBytes = runPut $ putWord32le $ fromIntegral $ BS.length vendorBytes @@ -293,104 +299,67 @@ return $ header <> vorbisData --- | Generate Vorbis comments from metadata +-- | Generate Vorbis comments from metadata. Every field the FLAC parser +-- maps is written back, and unmapped comments in rawTags are carried over +-- so an update never drops tags it does not understand. generateVorbisComments :: Metadata -> Writer [(Text, Text)] -generateVorbisComments metadata = do - let comments = [] - - -- Add standard tags - let comments1 = case title metadata of - Just t -> ("TITLE", t) : comments - Nothing -> comments - - let comments2 = case artist metadata of - Just a -> ("ARTIST", a) : comments1 - Nothing -> comments1 - - let comments3 = case album metadata of - Just a -> ("ALBUM", a) : comments2 - Nothing -> comments2 - - let comments4 = case albumArtist metadata of - Just aa -> ("ALBUMARTIST", aa) : comments3 - Nothing -> comments3 - - let comments5 = case trackNumber metadata of - Just n -> ("TRACKNUMBER", T.pack $ show n) : comments4 - Nothing -> comments4 - - let comments6 = case discNumber metadata of - Just n -> ("DISCNUMBER", T.pack $ show n) : comments5 - Nothing -> comments5 - - let comments7 = case year metadata of - Just y -> ("DATE", T.pack $ show y) : comments6 - Nothing -> comments6 - - let comments8 = case genre metadata of - Just g -> ("GENRE", g) : comments7 - Nothing -> comments7 - - let comments9 = case comment metadata of - Just c -> ("COMMENT", c) : comments8 - Nothing -> comments8 - - let comments10 = case publisher metadata of - Just p -> ("PUBLISHER", p) : comments9 - Nothing -> comments9 - - -- Add MusicBrainz IDs - let mbIds = musicBrainzIds metadata - let comments11 = case mbRecordingId mbIds of - Just mbId -> ("MUSICBRAINZ_TRACKID", mbId) : comments10 - Nothing -> comments10 - - let comments12 = case mbReleaseId mbIds of - Just mbId -> ("MUSICBRAINZ_ALBUMID", mbId) : comments11 - Nothing -> comments11 - - let comments13 = case mbArtistId mbIds of - Just mbId -> ("MUSICBRAINZ_ARTISTID", mbId) : comments12 - Nothing -> comments12 - - let comments14 = case mbAlbumArtistId mbIds of - Just mbId -> ("MUSICBRAINZ_ALBUMARTISTID", mbId) : comments13 - Nothing -> comments13 - - let comments15 = case mbReleaseGroupId mbIds of - Just mbId -> ("MUSICBRAINZ_RELEASEGROUPID", mbId) : comments14 - Nothing -> comments14 - - -- Add additional metadata fields - let comments16 = case date metadata of - Just d -> ("DATE", d) : comments15 - Nothing -> comments15 - - let comments17 = case barcode metadata of - Just b -> ("BARCODE", b) : comments16 - Nothing -> comments16 - - let comments18 = case catalogNumber metadata of - Just cn -> ("CATALOGNUMBER", cn) : comments17 - Nothing -> comments17 - - let comments19 = case recordLabel metadata of - Just rl -> ("LABEL", rl) : comments18 - Nothing -> comments18 - - let comments20 = case releaseCountry metadata of - Just rc -> ("RELEASECOUNTRY", rc) : comments19 - Nothing -> comments19 +generateVorbisComments metadata = return $ mappedComments ++ preservedComments + where + mbIds = musicBrainzIds metadata + showT = T.pack . show - let comments21 = case releaseStatus metadata of - Just rs -> ("RELEASESTATUS", rs) : comments20 - Nothing -> comments20 + mappedComments = catMaybes + [ ("TITLE",) <$> title metadata + , ("ARTIST",) <$> artist metadata + , ("ALBUM",) <$> album metadata + , ("ALBUMARTIST",) <$> albumArtist metadata + , ("TRACKNUMBER",) . showT <$> trackNumber metadata + , ("TRACKTOTAL",) . showT <$> totalTracks metadata + , ("DISCNUMBER",) . showT <$> discNumber metadata + , ("DISCTOTAL",) . showT <$> totalDiscs metadata + , ("DATE",) <$> (date metadata <|> (showT <$> year metadata)) + , ("GENRE",) <$> genre metadata + , ("COMMENT",) <$> comment metadata + , ("PUBLISHER",) <$> publisher metadata + , ("BARCODE",) <$> barcode metadata + , ("CATALOGNUMBER",) <$> catalogNumber metadata + , ("LABEL",) <$> recordLabel metadata + , ("RELEASECOUNTRY",) <$> releaseCountry metadata + , ("RELEASESTATUS",) <$> releaseStatus metadata + , ("RELEASETYPE",) <$> releaseType metadata + , ("MUSICBRAINZ_RELEASETRACKID",) <$> mbTrackId mbIds + , ("MUSICBRAINZ_TRACKID",) <$> mbRecordingId mbIds + , ("MUSICBRAINZ_ALBUMID",) <$> mbReleaseId mbIds + , ("MUSICBRAINZ_RELEASEGROUPID",) <$> mbReleaseGroupId mbIds + , ("MUSICBRAINZ_ARTISTID",) <$> mbArtistId mbIds + , ("MUSICBRAINZ_ALBUMARTISTID",) <$> mbAlbumArtistId mbIds + , ("MUSICBRAINZ_WORKID",) <$> mbWorkId mbIds + , ("MUSICBRAINZ_DISCID",) <$> mbDiscId mbIds + , ("ACOUSTID_FINGERPRINT",) <$> acoustidFingerprint metadata + , ("ACOUSTID_ID",) <$> acoustidId metadata + ] - let comments22 = case releaseType metadata of - Just rt -> ("RELEASETYPE", rt) : comments21 - Nothing -> comments21 + -- Keys the mapped fields own (whether or not they are set right now): + -- stale rawTags copies of these must not be written back + handledKeys = + [ "TITLE", "ARTIST", "ALBUM", "ALBUMARTIST" + , "TRACKNUMBER", "TRACKTOTAL", "DISCNUMBER", "DISCTOTAL" + , "DATE", "YEAR", "GENRE", "COMMENT", "PUBLISHER" + , "BARCODE", "CATALOGNUMBER", "LABEL", "RELEASECOUNTRY" + , "RELEASESTATUS", "RELEASETYPE" + , "MUSICBRAINZ_RELEASETRACKID", "MUSICBRAINZ_TRACKID" + , "MUSICBRAINZ_ALBUMID", "MUSICBRAINZ_RELEASEGROUPID" + , "MUSICBRAINZ_ARTISTID", "MUSICBRAINZ_ALBUMARTISTID" + , "MUSICBRAINZ_WORKID", "MUSICBRAINZ_DISCID" + , "ACOUSTID_FINGERPRINT", "ACOUSTID_ID" + , "METADATA_BLOCK_PICTURE" -- art is written as a PICTURE block instead + ] - return comments22 + preservedComments = + [ (key, value) + | (key, value) <- HM.toList (rawTags metadata) + , T.toUpper key `notElem` handledKeys + ] -- | Generate Picture block for album art generatePictureBlock :: AlbumArt -> Bool -> Writer L.ByteString diff --git a/src/Monatone/M4A.hs b/src/Monatone/M4A.hs --- a/src/Monatone/M4A.hs +++ b/src/Monatone/M4A.hs @@ -317,6 +317,8 @@ , comment = HM.lookup "\169cmt" tags , publisher = HM.lookup "\169pub" tags , releaseCountry = lookupFreeform "MusicBrainz Album Release Country" tags + , releaseStatus = lookupFreeform "MusicBrainz Album Status" tags + , releaseType = lookupFreeform "MusicBrainz Album Type" tags , recordLabel = lookupFreeform "LABEL" tags , catalogNumber = lookupFreeform "CATALOGNUMBER" tags , barcode = lookupFreeform "BARCODE" tags @@ -470,16 +472,16 @@ entryData <- BS.hGet handle 28 -- AudioSampleEntry header if BS.length entryData < 28 - then return emptyAudioProperties + then return emptyAudioProperties { codec = codecFromName (atomName entry) } else do let entryChannels = runGet getWord16be (L.fromStrict $ BS.take 2 $ BS.drop 16 entryData) entrySampleSize = runGet getWord16be (L.fromStrict $ BS.take 2 $ BS.drop 18 entryData) entrySampleRate = (runGet getWord32be (L.fromStrict $ BS.take 4 $ BS.drop 24 entryData)) `div` 65536 - codec = atomName entry + codecName = atomName entry - -- Parse extension atoms for more details - case atomChildren entry of + -- Parse extension atoms for more details, then stamp the codec on the result + props <- case atomChildren entry of Nothing -> return $ emptyAudioProperties { channels = Just $ fromIntegral entryChannels , bitsPerSample = Just $ fromIntegral entrySampleSize @@ -490,7 +492,7 @@ let esdsAtom = listToMaybe $ filter (\a -> atomName a == "esds") exts let alacAtom = listToMaybe $ filter (\a -> atomName a == "alac") exts - case (codec, esdsAtom, alacAtom) of + case (codecName, esdsAtom, alacAtom) of ("mp4a", Just esds, _) -> parseEsdsAtom handle esds entryChannels entrySampleSize entrySampleRate ("alac", _, Just alac) -> parseAlacAtom handle alac _ -> return $ emptyAudioProperties @@ -498,6 +500,13 @@ , bitsPerSample = Just $ fromIntegral entrySampleSize , sampleRate = Just $ fromIntegral entrySampleRate } + return props { codec = codecFromName codecName } + +-- | Map an M4A sample-entry atom name to a codec +codecFromName :: BS.ByteString -> Maybe Codec +codecFromName "mp4a" = Just CodecAAC +codecFromName "alac" = Just CodecALAC +codecFromName _ = Nothing -- | Parse ESDS atom for AAC info parseEsdsAtom :: Handle -> Atom -> Word16 -> Word16 -> Word32 -> IO AudioProperties 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 @@ -8,6 +8,7 @@ , Writer ) where +import Control.Applicative ((<|>)) import Control.Exception (catch, IOException) import Control.Monad.Except (ExceptT, throwError, runExceptT) import Control.Monad.IO.Class (liftIO) @@ -16,6 +17,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L +import qualified Data.HashMap.Strict as HM import Data.Maybe (fromMaybe, maybeToList) import Data.Text (Text) import qualified Data.Text as T @@ -91,11 +93,11 @@ ilstData <- generateIlstData metadata maybeAlbumArt -- Write to destination - _ <- liftIO $ withBinaryFile srcPath ReadMode $ \srcHandle -> do + writeResult <- liftIO $ withBinaryFile srcPath ReadMode $ \srcHandle -> do withBinaryFile dstPath WriteMode $ \dstHandle -> do runExceptT $ rewriteM4AFile srcHandle dstHandle atoms moovOffset moovSize ilstData - return () + either throwError return writeResult -- Simple atom info for tracking during parse data AtomInfo = AtomInfo @@ -155,9 +157,13 @@ hSeek srcHandle AbsoluteSeek moovOffset moovData <- BS.hGet srcHandle (fromIntegral moovSize) - -- Rebuild moov with new ilst - let newMoovData = rebuildMoovAtom moovData newIlstData - L.hPut dstHandle newMoovData + -- Rebuild moov with new ilst, then fix up chunk offsets: stco/co64 + -- entries are absolute file positions, and resizing moov moves every + -- byte after moov's old end by the size delta. + let newMoovData = L.toStrict $ rebuildMoovAtom moovData newIlstData + delta = toInteger (BS.length newMoovData) - toInteger moovSize + oldMoovEnd = moovOffset + fromIntegral moovSize + BS.hPut dstHandle $ adjustChunkOffsets delta oldMoovEnd newMoovData -- Copy all atoms after moov liftIO $ copyAfterMoov srcHandle dstHandle moovOffset moovSize @@ -218,6 +224,62 @@ , [0,0,0,0, 0,0,0,0, 0] -- reserved ] +-- | Shift absolute chunk offsets in every stco/co64 table inside a moov atom. +-- Only offsets pointing at or beyond moov's old end move: data before moov +-- stays put, so those offsets stay valid regardless of the size delta. +adjustChunkOffsets :: Integer -> Integer -> ByteString -> ByteString +adjustChunkOffsets delta oldMoovEnd = goAtoms + where + containerNames = ["moov", "trak", "mdia", "minf", "stbl"] :: [ByteString] + + goAtoms bs + | BS.length bs < 8 = bs + | 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 bs -- corrupt size; leave the remainder untouched + else + let (atom, rest) = BS.splitAt atomSize bs + (header, content) = BS.splitAt headerLen atom + atom' + | name `elem` containerNames = header <> goAtoms content + | name == "stco" = header <> patchTable 4 content + | name == "co64" = header <> patchTable 8 content + | otherwise = atom + in atom' <> goAtoms rest + + -- Table layout: version/flags (4) + entry count (4) + count offsets + patchTable entryWidth content + | BS.length content < 8 + tableLen = content + | otherwise = prefix <> BS.concat (map patchEntry entries) <> trailer + where + count = if BS.length content >= 8 + then fromIntegral $ readWord32BE $ BS.take 4 $ BS.drop 4 content + else 0 + tableLen = count * entryWidth + (prefix, tableAndTrailer) = BS.splitAt 8 content + (table, trailer) = BS.splitAt tableLen tableAndTrailer + entries = [ BS.take entryWidth $ BS.drop (i * entryWidth) table + | i <- [0 .. count - 1] ] + + patchEntry entry = + let wide = BS.length entry == 8 + old = if wide + then toInteger $ readWord64BE entry + else toInteger $ readWord32BE entry + new = if old >= oldMoovEnd then old + delta else old + in if new == old + then entry + else L.toStrict $ runPut $ if wide + then putWord64be (fromIntegral new) + else putWord32be (fromIntegral new) + -- | Filter out udta atom from a sequence of atoms filterOutUdta :: ByteString -> L.ByteString filterOutUdta bs = go bs L.empty @@ -240,6 +302,9 @@ else go nextRemaining (acc <> atomData) -- Keep other atoms -- | Generate ilst atom data with all tags +-- | 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. generateIlstData :: Metadata -> Maybe AlbumArt -> Writer L.ByteString generateIlstData metadata maybeAlbumArt = do let tags = concat @@ -247,7 +312,7 @@ , renderTextTag "\169ART" <$> maybeToList (artist metadata) , renderTextTag "\169alb" <$> maybeToList (album metadata) , renderTextTag "aART" <$> maybeToList (albumArtist metadata) - , renderTextTag "\169day" <$> maybeToList (date metadata) + , renderTextTag "\169day" <$> maybeToList (date metadata <|> (T.pack . show <$> year metadata)) , renderTextTag "\169gen" <$> maybeToList (genre metadata) , renderTextTag "\169cmt" <$> maybeToList (comment metadata) , renderTextTag "\169pub" <$> maybeToList (publisher metadata) @@ -259,11 +324,18 @@ , renderFreeformTag "CATALOGNUMBER" <$> maybeToList (catalogNumber metadata) , renderFreeformTag "BARCODE" <$> maybeToList (barcode metadata) , renderFreeformTag "MusicBrainz Album Release Country" <$> maybeToList (releaseCountry metadata) + , renderFreeformTag "MusicBrainz Album Status" <$> maybeToList (releaseStatus metadata) + , renderFreeformTag "MusicBrainz Album Type" <$> maybeToList (releaseType metadata) -- MusicBrainz IDs , renderMusicBrainzIds (musicBrainzIds metadata) -- Acoustid , renderFreeformTag "Acoustid Fingerprint" <$> maybeToList (acoustidFingerprint metadata) , renderFreeformTag "Acoustid Id" <$> maybeToList (acoustidId metadata) + -- Unmapped tags carried over from the source file + , concat + [ renderPreservedTag key value + | (key, value) <- HM.toList (rawTags metadata) + ] ] return $ mconcat tags @@ -279,6 +351,44 @@ , 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 + renderPreservedTag :: Text -> Text -> [L.ByteString] + renderPreservedTag key value + | key `elem` handledAtoms || key `elem` handledFreeform = [] + | Just rest <- T.stripPrefix "----:" key + , (mean, nameWithColon) <- T.breakOn ":" rest + , name <- T.drop 1 nameWithColon + , not (T.null mean) && not (T.null name) + = [renderFreeformTagWith (TE.encodeUtf8 mean) (TE.encodeUtf8 name) value] + | T.isPrefixOf "\169" key + , T.length key == 4 + , all ((< 256) . fromEnum) (T.unpack key) + = [renderTextTag (latin1Bytes key) value] + | otherwise = [] + + latin1Bytes = BS.pack . map (fromIntegral . fromEnum) . T.unpack + -- | Render a text tag atom renderTextTag :: ByteString -> Text -> L.ByteString renderTextTag name value = @@ -312,9 +422,12 @@ -- | Render freeform tag (----:com.apple.iTunes:NAME) renderFreeformTag :: ByteString -> Text -> L.ByteString -renderFreeformTag name value = - let mean = "com.apple.iTunes" - meanAtom = renderAtom "mean" (runPut (putWord32be 0) <> L.fromStrict mean) +renderFreeformTag = renderFreeformTagWith "com.apple.iTunes" + +-- | Render freeform tag (----:MEAN:NAME) with an explicit mean +renderFreeformTagWith :: ByteString -> ByteString -> Text -> L.ByteString +renderFreeformTagWith mean name value = + let meanAtom = renderAtom "mean" (runPut (putWord32be 0) <> L.fromStrict mean) nameAtom = renderAtom "name" (runPut (putWord32be 0) <> L.fromStrict name) textData = TE.encodeUtf8 value dataAtom = renderDataAtom 1 textData -- Type 1 = UTF-8 diff --git a/src/Monatone/MP3.hs b/src/Monatone/MP3.hs --- a/src/Monatone/MP3.hs +++ b/src/Monatone/MP3.hs @@ -93,6 +93,9 @@ , album = HM.lookup "TALB" tagMap <|> HM.lookup "TAL" tagMap , albumArtist = HM.lookup "TPE2" tagMap <|> HM.lookup "TP2" tagMap , trackNumber = (HM.lookup "TRCK" tagMap <|> HM.lookup "TRK" tagMap) >>= parseTrackNumber + , totalTracks = (HM.lookup "TRCK" tagMap <|> HM.lookup "TRK" tagMap) >>= parseTotal + , discNumber = (HM.lookup "TPOS" tagMap <|> HM.lookup "TPA" tagMap) >>= parseTrackNumber + , totalDiscs = (HM.lookup "TPOS" tagMap <|> HM.lookup "TPA" tagMap) >>= parseTotal , year = ((HM.lookup "TYER" tagMap <|> HM.lookup "TYE" tagMap) >>= readInt) <|> (HM.lookup "TDRC" tagMap >>= extractYearFromDate) , date = HM.lookup "TDRC" tagMap @@ -115,8 +118,12 @@ parseTrackNumber t = case T.split (== '/') t of (n:_) -> readInt n _ -> Nothing + parseTotal t = case T.split (== '/') t of + (_:total:_) -> readInt total + _ -> Nothing extractMusicBrainzIds tags = MusicBrainzIds { mbTrackId = HM.lookup "UFID:http://musicbrainz.org" tags + <|> HM.lookup "TXXX:MusicBrainz Release Track Id" tags , mbRecordingId = HM.lookup "TXXX:MusicBrainz Recording Id" tags , mbReleaseId = HM.lookup "TXXX:MusicBrainz Album Id" tags , mbReleaseGroupId = HM.lookup "TXXX:MusicBrainz Release Group Id" tags @@ -531,6 +538,7 @@ { 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) diff --git a/src/Monatone/MP3/Writer.hs b/src/Monatone/MP3/Writer.hs --- a/src/Monatone/MP3/Writer.hs +++ b/src/Monatone/MP3/Writer.hs @@ -2,6 +2,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TupleSections #-} module Monatone.MP3.Writer ( writeMP3Metadata @@ -9,6 +10,7 @@ , Writer ) where +import Control.Applicative ((<|>)) import Control.Exception (catch, IOException) import Control.Monad.Except (ExceptT, throwError, runExceptT) import Control.Monad.IO.Class (liftIO) @@ -17,6 +19,8 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L +import qualified Data.HashMap.Strict as HM +import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -225,75 +229,103 @@ return $ header <> framesData --- | Generate all ID3v2.4 frames for the metadata +-- | Generate all ID3v2.4 frames for the metadata. Every field the MP3 +-- parser maps is written back, and unmapped frames in rawTags are carried +-- over so an update never drops tags it does not understand. generateFrames :: Metadata -> Maybe AlbumArt -> Writer [L.ByteString] generateFrames metadata maybeAlbumArt = do - -- Start with empty list - frames0 <- return [] - - -- Add text frames - frames1 <- addTextFrame frames0 "TIT2" (title metadata) - frames2 <- addTextFrame frames1 "TPE1" (artist metadata) - frames3 <- addTextFrame frames2 "TALB" (album metadata) - frames4 <- addTextFrame frames3 "TPE2" (albumArtist metadata) - frames5 <- addTextFrame frames4 "TCON" (genre metadata) - frames6 <- addTextFrame frames5 "TPUB" (publisher metadata) - - -- Add comment frame (COMM has special structure) - frames7 <- case comment metadata of - Nothing -> return frames6 - Just c -> do - commFrame <- generateCOMMFrame c - return $ frames6 ++ [commFrame] - - -- Add numeric frames - frames8 <- addNumericFrame frames7 "TRCK" (trackNumber metadata) - frames9 <- addNumericFrame frames8 "TPOS" (discNumber metadata) - frames10 <- addNumericFrame frames9 "TDRC" (year metadata) -- TDRC for recording date in ID3v2.4 + mapped <- sequence $ + [ generateTextFrame frameId value | (frameId, value) <- textFrames ] ++ + [ generateTXXXFrame description value | (description, value) <- txxxFrames ] - -- Add additional metadata fields using TXXX frames - frames11 <- addTXXXFrame frames10 "BARCODE" (barcode metadata) - frames12 <- addTXXXFrame frames11 "CATALOGNUMBER" (catalogNumber metadata) - frames13 <- addTXXXFrame frames12 "LABEL" (recordLabel metadata) - frames14 <- addTXXXFrame frames13 "MusicBrainz Album Release Country" (releaseCountry metadata) - frames15 <- addTXXXFrame frames14 "MusicBrainz Album Status" (releaseStatus metadata) - frames16 <- addTXXXFrame frames15 "MusicBrainz Album Type" (releaseType metadata) + commFrames <- case comment metadata of + Nothing -> return [] + Just c -> (: []) <$> generateCOMMFrame c - -- Add date field (separate from year) if present - frames17 <- addTextFrame frames16 "TDRC" (date metadata) + preserved <- generatePreservedFrames metadata - -- Add album art frame if provided - finalFrames <- case maybeAlbumArt of - Nothing -> return frames17 - Just artData -> do - apicFrame <- generateAPICFrame artData - return $ apicFrame : frames17 + apicFrames <- case maybeAlbumArt of + Nothing -> return [] + Just art -> (: []) <$> generateAPICFrame art - return finalFrames + return $ mapped ++ commFrames ++ preserved ++ apicFrames where - -- Helper to add text frame if value is present - addTextFrame :: [L.ByteString] -> ByteString -> Maybe Text -> Writer [L.ByteString] - addTextFrame frameList frameId maybeText = case maybeText of - Nothing -> return frameList - Just text -> do - frame <- generateTextFrame frameId text - return $ frame : frameList - - -- Helper to add numeric frame if value is present - addNumericFrame :: [L.ByteString] -> ByteString -> Maybe Int -> Writer [L.ByteString] - addNumericFrame frameList frameId maybeNum = case maybeNum of - Nothing -> return frameList - Just num -> do - frame <- generateTextFrame frameId (T.pack $ show num) - return $ frame : frameList + mbIds = musicBrainzIds metadata + showT = T.pack . show - -- Helper to add TXXX frame if value is present - addTXXXFrame :: [L.ByteString] -> Text -> Maybe Text -> Writer [L.ByteString] - addTXXXFrame frameList description maybeText = case maybeText of - Nothing -> return frameList - Just text -> do - frame <- generateTXXXFrame description text - return $ frame : frameList + -- "7" alone, or "7/12" when the total is known + numWithTotal num total = renderNum <$> num + where renderNum n = maybe (showT n) (\t -> showT n <> "/" <> showT t) total + + textFrames = catMaybes + [ ("TIT2",) <$> title metadata + , ("TPE1",) <$> artist metadata + , ("TALB",) <$> album metadata + , ("TPE2",) <$> albumArtist metadata + , ("TCON",) <$> genre metadata + , ("TPUB",) <$> publisher metadata + , ("TRCK",) <$> numWithTotal (trackNumber metadata) (totalTracks metadata) + , ("TPOS",) <$> numWithTotal (discNumber metadata) (totalDiscs metadata) + , ("TDRC",) <$> (date metadata <|> (showT <$> year metadata)) + ] + + txxxFrames = catMaybes + [ ("BARCODE",) <$> barcode metadata + , ("CATALOGNUMBER",) <$> catalogNumber metadata + , ("LABEL",) <$> recordLabel metadata + , ("MusicBrainz Album Release Country",) <$> releaseCountry metadata + , ("MusicBrainz Album Status",) <$> releaseStatus metadata + , ("MusicBrainz Album Type",) <$> releaseType metadata + , ("MusicBrainz Release Track Id",) <$> mbTrackId mbIds + , ("MusicBrainz Recording Id",) <$> mbRecordingId mbIds + , ("MusicBrainz Album Id",) <$> mbReleaseId mbIds + , ("MusicBrainz Release Group Id",) <$> mbReleaseGroupId mbIds + , ("MusicBrainz Artist Id",) <$> mbArtistId mbIds + , ("MusicBrainz Album Artist Id",) <$> mbAlbumArtistId mbIds + , ("MusicBrainz Work Id",) <$> mbWorkId mbIds + , ("MusicBrainz Disc Id",) <$> mbDiscId mbIds + , ("Acoustid Fingerprint",) <$> acoustidFingerprint metadata + , ("Acoustid Id",) <$> acoustidId metadata + ] + +-- | Re-emit raw frames the mapped fields do not own. rawTags only holds +-- text-decoded values, so preservation is limited to frames that can be +-- reproduced faithfully from text: T-frames and TXXX +generatePreservedFrames :: Metadata -> Writer [L.ByteString] +generatePreservedFrames metadata = mapM emit preservable + where + preservable = + [ kv | kv@(key, _) <- HM.toList (rawTags metadata), isPreservable key ] + + isPreservable key + | Just description <- T.stripPrefix "TXXX:" key = + T.toLower description `notElem` handledDescriptions + | otherwise = + T.length key == 4 && T.isPrefixOf "T" key && key `notElem` handledTextFrames + + emit (key, value) = case T.stripPrefix "TXXX:" key of + Just description -> generateTXXXFrame description value + Nothing -> generateTextFrame (TE.encodeUtf8 key) value + + -- Frames the mapped fields own (whether or not they are set right now): + -- stale rawTags copies of these must not be written back + handledTextFrames = + [ "TIT2", "TPE1", "TALB", "TPE2", "TCON", "TPUB", "TRCK", "TPOS" + , "TDRC", "TXXX" + -- legacy v2.3 date frames, superseded by the TDRC we write + , "TYER", "TDAT", "TIME", "TRDA" + ] + + handledDescriptions = map T.toLower + [ "BARCODE", "CATALOGNUMBER", "LABEL", "comment" + , "MusicBrainz Album Release Country", "MusicBrainz Album Status" + , "MusicBrainz Album Type" + , "MusicBrainz Release Track Id", "MusicBrainz Recording 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 a text frame (TIT2, TPE1, TALB, etc.) generateTextFrame :: ByteString -> Text -> Writer L.ByteString diff --git a/src/Monatone/Metadata.hs b/src/Monatone/Metadata.hs --- a/src/Monatone/Metadata.hs +++ b/src/Monatone/Metadata.hs @@ -6,6 +6,7 @@ -- audio metadata across different formats (FLAC, MP3, OGG/Vorbis, Opus). module Monatone.Metadata ( AudioFormat(..) + , Codec(..) , Metadata(..) , AudioProperties(..) , MusicBrainzIds(..) @@ -48,6 +49,36 @@ "m4a" -> return M4A _ -> fail $ "Unknown audio format: " ++ show t +-- | Audio codec — the actual compression scheme, distinct from the container +-- format ('AudioFormat'). A single container can carry different codecs +-- (e.g. M4A holds either AAC or ALAC). +data Codec + = CodecFLAC -- ^ FLAC lossless + | CodecMP3 -- ^ MPEG-1/2 Audio Layer III (lossy) + | CodecVorbis -- ^ Ogg Vorbis (lossy) + | CodecOpus -- ^ Opus (lossy) + | CodecAAC -- ^ Advanced Audio Coding (lossy) + | CodecALAC -- ^ Apple Lossless + deriving (Show, Eq, Ord, Read) + +instance ToJSON Codec where + toJSON CodecFLAC = "flac" + toJSON CodecMP3 = "mp3" + toJSON CodecVorbis = "vorbis" + toJSON CodecOpus = "opus" + toJSON CodecAAC = "aac" + toJSON CodecALAC = "alac" + +instance FromJSON Codec where + parseJSON = withText "Codec" $ \t -> case t of + "flac" -> return CodecFLAC + "mp3" -> return CodecMP3 + "vorbis" -> return CodecVorbis + "opus" -> return CodecOpus + "aac" -> return CodecAAC + "alac" -> return CodecALAC + _ -> fail $ "Unknown codec: " ++ show t + -- | Audio file properties data AudioProperties = AudioProperties { duration :: Maybe Int -- Duration in milliseconds @@ -55,6 +86,7 @@ , sampleRate :: Maybe Int -- Sample rate in Hz , channels :: Maybe Int -- Number of channels , bitsPerSample :: Maybe Int -- Bits per sample (bit depth) + , codec :: Maybe Codec -- Audio codec (e.g. AAC vs ALAC within M4A) } deriving (Show, Eq) -- | MusicBrainz identifiers @@ -154,6 +186,7 @@ , sampleRate = Nothing , channels = Nothing , bitsPerSample = Nothing + , codec = Nothing } -- | Empty MusicBrainz IDs diff --git a/src/Monatone/OGG.hs b/src/Monatone/OGG.hs --- a/src/Monatone/OGG.hs +++ b/src/Monatone/OGG.hs @@ -79,10 +79,12 @@ pageData <- BS.hGet handle pageDataSize -- Check packet type - let (newMetadata, newFoundIdent, newFoundComment) = + let (newMetadata, newFoundIdent, newFoundComment) = if "\x01vorbis" `BS.isPrefixOf` pageData && not foundIdent then (parseVorbisInfo pageData metadata, True, foundComment) - else if "\x03vorbis" `BS.isPrefixOf` pageData && not foundComment + else if "OpusHead" `BS.isPrefixOf` pageData && not foundIdent + then (parseOpusInfo pageData metadata, True, foundComment) + else if "\x03vorbis" `BS.isPrefixOf` pageData && not foundComment then (parseVorbisComment pageData metadata, foundIdent, True) else (metadata, foundIdent, foundComment) @@ -127,6 +129,32 @@ , bitrate = bitrate' , bitsPerSample = Nothing -- Not in Vorbis info , duration = Nothing -- Would need granule position from last page + , codec = Just CodecVorbis + } + } + +-- | Parse Opus identification header (the "OpusHead" packet) +parseOpusInfo :: BS.ByteString -> Metadata -> Metadata +parseOpusInfo bs metadata = + if BS.length bs < 19 -- 8 (magic) + version + channels + pre-skip + input rate + gain + mapping + then metadata + else + let lazyBs = L.fromStrict bs + in case runGetOrFail (parseOpusInfoGet metadata) (L.drop 8 lazyBs) of + Left _ -> metadata + Right (_, _, result) -> result + +parseOpusInfoGet :: Metadata -> Get Metadata +parseOpusInfoGet metadata = do + _ <- getWord8 -- version + opusChannels <- getWord8 + _ <- getWord16le -- pre-skip + inputSampleRate <- getWord32le -- original sample rate before Opus resampled to 48k + return $ metadata + { audioProperties = emptyAudioProperties + { sampleRate = Just $ fromIntegral inputSampleRate + , channels = Just $ fromIntegral opusChannels + , codec = Just CodecOpus } } diff --git a/src/Monatone/Writer.hs b/src/Monatone/Writer.hs --- a/src/Monatone/Writer.hs +++ b/src/Monatone/Writer.hs @@ -35,7 +35,6 @@ , removeAlbumArt -- * Writing operations , writeMetadata - , writeMetadataToFile , updateMetadata ) where @@ -44,8 +43,7 @@ import Data.Text (Text) import qualified Data.Text as T import System.OsPath -import System.Directory.OsPath (renameFile, removeFile) -import System.File.OsPath (readFile', writeFile') +import System.Directory.OsPath (copyFile, renameFile, removeFile) import Control.Exception (try, IOException, evaluate) import Monatone.Metadata @@ -246,9 +244,43 @@ applyMaybeUpdate Nothing current = current -- No change applyMaybeUpdate (Just newValue) _ = newValue -- Apply change (including clearing) --- | Write complete metadata to a new file +-- | Write complete metadata to a file, atomically. +-- +-- The file is copied to a temporary sibling, the format writer modifies the +-- copy, and the copy is renamed over the original. A crash or failed write +-- leaves the original untouched (at worst a stray @.monatone.tmp@ file). writeMetadata :: Metadata -> Maybe AlbumArt -> OsPath -> Writer () writeMetadata metadata maybeAlbumArt filePath = do + -- The temp file must be a sibling of the target: rename is only atomic + -- within a filesystem + let tmpPath = filePath <> [osp|.monatone.tmp|] + + copyResult <- liftIO $ try $ copyFile filePath tmpPath + case copyResult of + Left (ioErr :: IOException) -> + throwError $ WriteIOError $ "Failed to create temporary copy: " <> T.pack (show ioErr) + Right () -> do + writeResult <- liftIO $ runExceptT $ dispatchWrite metadata maybeAlbumArt tmpPath + case writeResult of + Left err -> do + discardTemp tmpPath + throwError err + Right () -> do + renameResult <- liftIO $ try $ renameFile tmpPath filePath + case renameResult of + Left (ioErr :: IOException) -> do + discardTemp tmpPath + throwError $ WriteIOError $ "Failed to replace file: " <> T.pack (show ioErr) + Right () -> return () + where + discardTemp :: OsPath -> Writer () + discardTemp path = do + _ <- liftIO $ (try :: IO () -> IO (Either IOException ())) $ removeFile path + return () + +-- | Dispatch to the format-specific writer, which modifies the file in place +dispatchWrite :: Metadata -> Maybe AlbumArt -> OsPath -> Writer () +dispatchWrite metadata maybeAlbumArt filePath = do let audioFormat = format metadata case audioFormat of MP3 -> writeMP3Metadata metadata maybeAlbumArt filePath @@ -256,36 +288,6 @@ M4A -> writeM4AMetadata metadata maybeAlbumArt filePath _ -> throwError $ UnsupportedWriteFormat audioFormat --- | Write metadata to the same file (with backup) -writeMetadataToFile :: Metadata -> Maybe AlbumArt -> OsPath -> Writer () -writeMetadataToFile metadata maybeAlbumArt filePath = do - -- Create backup path by appending .backup to filename - let backupPath = filePath <> [osp|.backup|] - - -- Create backup by copying (not renaming) so original stays available for writers - backupResult <- liftIO $ try $ do - content <- readFile' filePath - writeFile' backupPath content - case backupResult of - Left (ioErr :: IOException) -> throwError $ WriteIOError $ "Failed to create backup: " <> T.pack (show ioErr) - Right _ -> do - -- Try to write new file - writeResult <- liftIO $ runExceptT $ writeMetadata metadata maybeAlbumArt filePath - case writeResult of - Left err -> do - -- Restore backup on failure - restoreResult <- liftIO $ try $ renameFile backupPath filePath - case restoreResult of - Left (restoreErr :: IOException) -> - throwError $ WriteIOError $ "Write failed and backup restore failed: " <> T.pack (show restoreErr) - Right _ -> throwError err - Right _ -> do - -- Success - clean up backup - cleanupResult <- liftIO $ (try :: IO () -> IO (Either IOException ())) $ removeFile backupPath - case cleanupResult of - Left _ -> return () -- Ignore cleanup errors - Right _ -> return () - -- | Update existing file with metadata changes updateMetadata :: OsPath -> MetadataUpdate -> Writer () updateMetadata filePath update = do @@ -315,7 +317,7 @@ Right art -> return art -- Write back - writeMetadataToFile updatedMetadata maybeArt filePath + writeMetadata updatedMetadata maybeArt filePath -- | Write MP3 metadata using the MP3Writer module writeMP3Metadata :: Metadata -> Maybe AlbumArt -> OsPath -> Writer () diff --git a/test/Test/IntegrationSpec.hs b/test/Test/IntegrationSpec.hs --- a/test/Test/IntegrationSpec.hs +++ b/test/Test/IntegrationSpec.hs @@ -13,7 +13,12 @@ import Control.Exception (catch, SomeException) import Control.Monad (unless) import System.OsPath hiding (()) +import Data.Bits ((.&.), (.|.), shiftL) +import qualified Data.ByteString as BS +import qualified Data.HashMap.Strict as HM +import Data.Text (Text) import qualified Data.Text as T +import Data.Word (Word8) import Monatone.Common (parseMetadata) import Monatone.Metadata @@ -33,7 +38,157 @@ , testFLACRoundTrip , testM4ARoundTrip ] + , testGroup "Write Safety" + [ testFailedWriteLeavesOriginalIntact + ] + , testGroup "Tag Preservation" + [ testTagPreservation "MP3" "minimal.mp3" + [("TXXX:MyCustomTag", "custom-value"), ("TMOO", "Chill")] + , testTagPreservation "FLAC" "minimal.flac" + [("MYCUSTOMTAG", "custom-value")] + , testTagPreservation "M4A" "minimal.m4a" + [("----:com.example.test:CustomField", "custom-value"), ("\169wrt", "A Composer")] + , testFLACBlockPreservation + ] ] + +-- | Updating one field must not drop MusicBrainz/AcoustID tags, track and +-- disc totals, release status/type, or tags the writer does not map at all +testTagPreservation :: String -> FilePath -> [(Text, Text)] -> TestTree +testTagPreservation label fixtureName customTags = + testCase (label ++ " update preserves unrelated tags") $ do + tmpDir <- getTemporaryDirectory + let origPath = fixturesDir fixtureName + tmpPath = tmpDir "monatone-test-preserve-" ++ fixtureName + origExists <- doesFileExist origPath + unless origExists $ assertFailure "Test skipped: fixture not available (run with ffmpeg to generate)" + copyFile origPath tmpPath + osTmpPath <- toOsPath tmpPath + + -- Enrich the file with everything an update must not lose + parsed <- parseMetadata osTmpPath >>= either (assertFailure . show) return + let enriched = parsed + { musicBrainzIds = MusicBrainzIds + { mbTrackId = Just "mb-track" + , mbRecordingId = Just "mb-recording" + , mbReleaseId = Just "mb-release" + , mbReleaseGroupId = Just "mb-release-group" + , mbArtistId = Just "mb-artist" + , mbAlbumArtistId = Just "mb-album-artist" + , mbWorkId = Just "mb-work" + , mbDiscId = Just "mb-disc" + } + , acoustidFingerprint = Just "fp-12345" + , acoustidId = Just "acoustid-67890" + -- MP3/M4A can only carry totals alongside a number ("n/total"), + -- so the numbers must be present too + , trackNumber = Just 7 + , totalTracks = Just 12 + , discNumber = Just 1 + , totalDiscs = Just 2 + , releaseStatus = Just "official" + , releaseType = Just "album" + , rawTags = foldr (uncurry HM.insert) (rawTags parsed) customTags + } + runExceptT (writeMetadata enriched Nothing osTmpPath) + >>= either (assertFailure . show) return + + -- The regression under test: an unrelated update must keep all of it + runExceptT (updateMetadata osTmpPath (setTitle "Preserved Title Test" emptyUpdate)) + >>= either (assertFailure . show) return + + final <- parseMetadata osTmpPath >>= either (assertFailure . show) return + assertEqual "title updated" (Just "Preserved Title Test") (title final) + let mbIds = musicBrainzIds final + assertEqual "mbTrackId" (Just "mb-track") (mbTrackId mbIds) + assertEqual "mbRecordingId" (Just "mb-recording") (mbRecordingId mbIds) + assertEqual "mbReleaseId" (Just "mb-release") (mbReleaseId mbIds) + assertEqual "mbReleaseGroupId" (Just "mb-release-group") (mbReleaseGroupId mbIds) + assertEqual "mbArtistId" (Just "mb-artist") (mbArtistId mbIds) + assertEqual "mbAlbumArtistId" (Just "mb-album-artist") (mbAlbumArtistId mbIds) + assertEqual "mbWorkId" (Just "mb-work") (mbWorkId mbIds) + assertEqual "mbDiscId" (Just "mb-disc") (mbDiscId mbIds) + assertEqual "acoustidFingerprint" (Just "fp-12345") (acoustidFingerprint final) + assertEqual "acoustidId" (Just "acoustid-67890") (acoustidId final) + assertEqual "totalTracks" (Just 12) (totalTracks final) + assertEqual "totalDiscs" (Just 2) (totalDiscs final) + assertEqual "releaseStatus" (Just "official") (releaseStatus final) + assertEqual "releaseType" (Just "album") (releaseType final) + mapM_ (\(key, value) -> + assertEqual ("custom tag " ++ T.unpack key) (Just value) (HM.lookup key (rawTags final))) + customTags + removeFile tmpPath + +-- | FLAC updates must carry over metadata blocks they do not regenerate +-- (SEEKTABLE, APPLICATION, CUESHEET) +testFLACBlockPreservation :: TestTree +testFLACBlockPreservation = testCase "FLAC update preserves SEEKTABLE block" $ do + tmpDir <- getTemporaryDirectory + let origPath = fixturesDir "minimal.flac" + tmpPath = tmpDir "monatone-test-seektable.flac" + origExists <- doesFileExist origPath + unless origExists $ assertFailure "Test skipped: fixture not available (run with ffmpeg to generate)" + + -- Insert a synthetic SEEKTABLE (type 3, one placeholder seekpoint) after + -- STREAMINFO: 4-byte signature + 38-byte STREAMINFO block, then the rest + orig <- BS.readFile origPath + let (prefix, rest) = BS.splitAt 42 orig + seekPoint = BS.replicate 18 0xFF -- placeholder seekpoint per spec + seekTable = BS.pack [3, 0, 0, 18] <> seekPoint + BS.writeFile tmpPath (prefix <> seekTable <> rest) + + osTmpPath <- toOsPath tmpPath + runExceptT (updateMetadata osTmpPath (setTitle "Block Preservation" emptyUpdate)) + >>= either (assertFailure . show) return + + final <- BS.readFile tmpPath + let blocks = flacBlocks final + assertBool "SEEKTABLE block survived the update" $ + (3, seekTable) `elem` [(t, BS.pack [3, 0, 0, 18] <> c) | (t, c) <- blocks, t == 3] + removeFile tmpPath + where + -- Walk the metadata blocks of a FLAC file: (type, content) pairs + flacBlocks :: BS.ByteString -> [(Word8, BS.ByteString)] + flacBlocks bs = go 4 + where + go pos + | pos + 4 > BS.length bs = [] + | otherwise = + let hdr = BS.index bs pos + btype = hdr .&. 0x7F + len = (fromIntegral (BS.index bs (pos + 1)) `shiftL` 16) .|. + (fromIntegral (BS.index bs (pos + 2)) `shiftL` 8) .|. + fromIntegral (BS.index bs (pos + 3)) + content = BS.take len (BS.drop (pos + 4) bs) + next = if hdr .&. 0x80 /= 0 then [] else go (pos + 4 + len) + in (btype, content) : next + +-- | Writes go through a temp copy + atomic rename, so a failed write must +-- leave the original file byte-identical and clean up its temp file. +testFailedWriteLeavesOriginalIntact :: TestTree +testFailedWriteLeavesOriginalIntact = testCase "Failed write leaves original untouched" $ do + tmpDir <- getTemporaryDirectory + let origPath = fixturesDir "minimal.flac" + tmpPath = tmpDir "monatone-test-atomic.flac" + + origExists <- doesFileExist origPath + unless origExists $ assertFailure "Test skipped: fixture not available (run with ffmpeg to generate)" + copyFile origPath tmpPath + before <- BS.readFile tmpPath + + -- Force a failure: metadata claims M4A, but the file is FLAC, so the + -- M4A writer errors out partway through + osTmpPath <- toOsPath tmpPath + result <- runExceptT $ writeMetadata (emptyMetadata M4A) Nothing osTmpPath + case result of + Left _ -> return () + Right () -> assertFailure "Expected write to fail on mismatched format" + + after <- BS.readFile tmpPath + assertEqual "original bytes unchanged after failed write" before after + leftover <- doesFileExist (tmpPath ++ ".monatone.tmp") + assertBool "no temp file left behind" (not leftover) + removeFile tmpPath -- | Ensure test fixtures exist, generate them if missing ensureFixtures :: IO () diff --git a/test/Test/M4ASpec.hs b/test/Test/M4ASpec.hs --- a/test/Test/M4ASpec.hs +++ b/test/Test/M4ASpec.hs @@ -8,10 +8,15 @@ import Test.Tasty.HUnit import Control.Monad.Except (runExceptT) import Control.Exception (try, IOException) -import System.OsPath +import Data.Bits (shiftR) +import qualified Data.ByteString as BS +import System.Directory (getTemporaryDirectory, removeFile) +import System.FilePath (()) +import System.OsPath hiding (()) import Data.Text (Text) import Monatone.M4A (parseM4A, loadAlbumArtM4A) +import Monatone.M4A.Writer (writeM4AMetadata) import Monatone.Metadata tests :: TestTree @@ -23,6 +28,9 @@ , testGroup "Album art" [ testLoadAlbumArt ] + , testGroup "Writer chunk offsets" + [ testChunkOffsetAdjustment + ] ] testParseM4AErrors :: TestTree @@ -64,3 +72,67 @@ -- Would test with actual fixture return () ] + +-- | Rewriting metadata resizes moov; in moov-first files the absolute chunk +-- offsets in stco/co64 must shift with the mdat data or the audio is lost. +testChunkOffsetAdjustment :: TestTree +testChunkOffsetAdjustment = testGroup "stco/co64 adjustment on moov resize" + [ testCase "stco offsets still point at chunk data after write" $ + checkChunkOffsets "stco" "stco" w32 + , testCase "co64 offsets still point at chunk data after write" $ + checkChunkOffsets "co64" "co64" w64 + ] + where + chunk1 = "CHUNKONEDATA" :: BS.ByteString + chunk2 = "CHUNKTWODATA" :: BS.ByteString + + checkChunkOffsets label tableName putOffset = do + tmpDir <- getTemporaryDirectory + let tmpPath = tmpDir "monatone-test-" ++ label ++ ".m4a" + BS.writeFile tmpPath (buildMoovFirstFile tableName putOffset) + + osTmpPath <- encodeFS tmpPath + let meta = (emptyMetadata M4A) { title = Just "A considerably longer replacement title" } + result <- runExceptT $ writeM4AMetadata meta Nothing osTmpPath + case result of + Left err -> assertFailure $ "Write failed: " ++ show err + Right () -> return () + + output <- BS.readFile tmpPath + removeFile tmpPath + + let atTable = snd $ BS.breakSubstring tableName output + assertBool "output contains offset table" (not (BS.null atTable)) + assertBool "offset table is unique" $ + BS.null $ snd $ BS.breakSubstring tableName (BS.drop 4 atTable) + let entryWidth = if tableName == ("co64" :: BS.ByteString) then 8 else 4 + tableBody = BS.drop 12 atTable -- name (4) + version/flags (4) + count (4) + readOffset i = readBE $ BS.take entryWidth $ BS.drop (i * entryWidth) tableBody + off1 = readOffset 0 + off2 = readOffset 1 + assertEqual "chunk 1 readable at patched offset" + chunk1 (BS.take (BS.length chunk1) (BS.drop off1 output)) + assertEqual "chunk 2 readable at patched offset" + chunk2 (BS.take (BS.length chunk2) (BS.drop off2 output)) + + -- Layout: ftyp | moov(trak(mdia(minf(stbl(stco|co64))))) | mdat(chunk1 chunk2) + buildMoovFirstFile tableName putOffset = + let moovFor off1 off2 = + atomBS "moov" $ atomBS "trak" $ atomBS "mdia" $ atomBS "minf" $ + atomBS "stbl" $ atomBS tableName $ + BS.concat [w32 0, w32 2, putOffset off1, putOffset off2] + ftyp = atomBS "ftyp" ("M4A " <> w32 0) + moovLen = BS.length (moovFor 0 0) -- offsets are fixed-width + mdatStart = BS.length ftyp + moovLen + off1 = mdatStart + 8 + off2 = off1 + BS.length chunk1 + in ftyp <> moovFor off1 off2 <> atomBS "mdat" (chunk1 <> chunk2) + + atomBS name content = + w32 (8 + BS.length content) <> name <> content + + w32, w64 :: Int -> BS.ByteString + w32 n = BS.pack [fromIntegral (n `shiftR` s) | s <- [24, 16, 8, 0]] + w64 n = BS.pack [fromIntegral (n `shiftR` s) | s <- [56, 48, 40, 32, 24, 16, 8, 0]] + + readBE = BS.foldl' (\acc b -> acc * 256 + fromIntegral b) 0