monatone 0.2.1.1 → 0.3.0.0

raw patch · 14 files changed

+728/−260 lines, 14 filesdep ~unordered-containersPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: unordered-containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +29/−0
• app/Main.hs +11/−0
• monatone.cabal +7/−2
• src/Monatone/FLAC.hs +4/−2
• src/Monatone/FLAC/Writer.hs +112/−143
• src/Monatone/M4A.hs +14/−5
• src/Monatone/M4A/Writer.hs +122/−9
• src/Monatone/MP3.hs +8/−0
• src/Monatone/MP3/Writer.hs +93/−61
• src/Monatone/Metadata.hs +33/−0
• src/Monatone/OGG.hs +30/−2
• src/Monatone/Writer.hs +37/−35
• test/Test/IntegrationSpec.hs +155/−0
• test/Test/M4ASpec.hs +73/−1

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

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

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

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

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

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

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

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

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

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

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

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

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

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