monatone 0.3.0.0 → 0.4.0.0

raw patch · 16 files changed

+2440/−830 lines, 16 filesdep +unixdep ~base64-bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: unix

Dependency ranges changed: base64-bytestring

API changes (from Hackage documentation)

Files

• CHANGELOG.md +106/−0
• monatone.cabal +7/−1
• src/Monatone/FLAC.hs +60/−47
• src/Monatone/FLAC/Writer.hs +156/−117
• src/Monatone/M4A.hs +114/−88
• src/Monatone/M4A/Writer.hs +101/−36
• src/Monatone/MP3.hs +313/−242
• src/Monatone/MP3/Writer.hs +227/−69
• src/Monatone/Metadata.hs +12/−1
• src/Monatone/OGG.hs +205/−153
• src/Monatone/OGG/Writer.hs +298/−0
• src/Monatone/Writer.hs +72/−53
• test/Spec.hs +2/−0
• test/Test/IntegrationSpec.hs +447/−22
• test/Test/M4ASpec.hs +1/−1
• test/Test/OGGSpec.hs +319/−0

@@ -1,5 +1,111 @@ # Changelog for `monatone` +## [0.4.0.0] - 2026-07-24++### Added+- **OGG/Opus tag writing**: Vorbis and Opus files can now be updated like+  every other format. The comment packet is rebuilt and repaginated,+  following pages are renumbered and their CRCs recomputed, and audio+  data is copied verbatim; the encoder's vendor string is preserved.+  Album art travels as METADATA_BLOCK_PICTURE comments (kept, set, or+  removed like the other formats). Verified against ffmpeg-generated+  files (tags readable by ffprobe, streams decode cleanly).+- **OGG/Opus duration** is computed from the final page's granule+  position (accounting for Opus pre-skip)+- **Writes are durable**: the temp file is fsynced before the atomic+  rename (unix only), so a power loss cannot leave a half-written file+- Multiple album art pictures survive updates: writers take an explicit+  art instruction (keep / set / remove), and "keep" carries all existing+  FLAC PICTURE blocks, MP3 APIC frames, and M4A covr atoms through+  verbatim+- MP3 binary frames (USLT lyrics, PRIV, GEOB, SYLT, POPM, URL frames,+  foreign UFIDs) are carried through updates verbatim; unmapped ID3v2.2+  text frames are translated to their v2.4 equivalents+- The FLAC writer preserves the original encoder's vendor string+- ID3v1/Winamp genre table: ID3v2.3 "(nn)" references and ID3v2.4 bare+  numeric genre strings resolve to genre names, and the ID3v1 genre byte+  is read as a fallback++### Changed+- **Breaking**: `writeMetadata` and the format writers take an+  `AlbumArtUpdate` (`KeepExistingArt` / `SetAlbumArt` / `RemoveAlbumArt`)+  instead of `Maybe AlbumArt`, whose `Nothing` conflated "no change"+  with "remove"+- `updateMetadata` detects the format from file content instead of the+  extension, and no longer reloads album art through the parser (whose+  failure used to silently delete artwork)+- **Breaking**: `rawTags` is now `HashMap Text [Text]` so multi-valued+  tags are represented faithfully. Scalar metadata fields (`artist`,+  `genre`, ...) expose the first value. On write, if a scalar field still+  matches the first stored value the whole list is written back; editing+  the field replaces the list.++### Fixed+- ALAC audio properties (bit depth, sample rate, channels) are read from+  the alac extension box; the extension-parsing branch was unreachable,+  so 24-bit files reported the sample-entry header's 16-bit claim, and+  the (dead) alac parser read the wrong offset for the sample rate+- MP3 UFID frames are parsed properly (owner + identifier) instead of+  being garbled by the text-frame parser; the MusicBrainz recording id+  is read from and written to UFID:http://musicbrainz.org per Picard+  convention (previously mapped to the wrong field and never matched)+- An existing ID3v1 tag is rewritten on update instead of keeping stale+  pre-update fields visible to v1-only readers+- ID3v2 header flags are now honoured: whole-tag unsynchronisation is+  reversed, the extended header is skipped (v2.3 and v2.4 layouts), and+  the v2.4 footer is accounted for when locating audio data; v2.4+  per-frame unsynchronisation and data-length indicators are handled too+- UTF-16 COMM/TXXX/USLT frames with descriptions decode correctly: the+  terminator search is now aligned to UTF-16 code units+- Xing/Info VBR headers are found in MPEG2/2.5 files (side-info offsets+  differ from MPEG1), fixing missing duration/bitrate for MPEG2 VBR+- ID3v1 fields decode as Latin-1 per spec instead of UTF-8; plain v1.0+  tags no longer lose the last 2 comment characters+- An MP3 frame sync spanning a 4096-byte scan-chunk boundary is no longer+  missed+- The MP3 writer replaces an existing tag's footer instead of leaving 10+  bytes of it before the audio+- Multi-valued tags (e.g. several ARTIST Vorbis comments) are no longer+  silently collapsed to one value+- Null-separated values in ID3v2.4 text frames are parsed as separate+  values instead of being concatenated into one string, and the MP3+  writer emits multi-valued frames null-separated per ID3v2.4 (one frame+  per ID, since duplicate frame IDs are invalid)+- Vorbis bitrate fields are read as signed, so the -1 "unset" sentinel is+  no longer reported as a ~4 Gbps bitrate+- Opus sample rate is reported as 48kHz (the decode rate) rather than the+  encoder's informational input rate+- FLAC album art loading continues past a corrupt Picture block to a+  later one instead of giving up+- Mixed-case file extensions (.Mp3, .Flac) are accepted for updates+- M4A disk atom is written with the 6-byte iTunes layout (trkn keeps its+  trailing reserved word); track/disc numbers are clamped to 16 bits+  instead of silently wrapping+- **Malformed-input hardening**: crafted or truncated files can no longer+  hang or crash the parsers and writers+  - M4A atoms with sizes smaller than their own header (including zero+    64-bit sizes) no longer cause infinite loops in the parser or writer+  - Truncated FLAC blocks and lying length fields inside Vorbis comments+    return clean parse results instead of throwing from pure code+  - An MP3 sync pattern with fewer than 4 bytes before EOF no longer+    crashes the frame-header parser; truncated Xing headers are read+    safely+  - M4A tag payload reads are clamped to the file size, so a lying atom+    size cannot trigger a huge allocation+  - FLAC writer errors out cleanly on truncated source blocks and on+    metadata blocks exceeding the 16MiB block-length limit instead of+    writing a corrupt stream+  - MP3 writer rejects content beyond ID3v2's 256MiB syncsafe size limit+    instead of silently truncating the size field+- **OGG packets are now reassembled across pages**: comment packets larger+  than one page (~64KB, i.e. any file with embedded album art) were+  previously truncated and all tags silently dropped+- Opus tags (`OpusTags` packet) are now parsed; previously Opus files+  returned no tags and the parser scanned the entire file+- OGG album art with base64 `=` padding no longer fails to decode+- OGG parser now populates `rawTags` and stops reading after the two+  metadata packets+ ## [0.3.0.0] - 2026-07-20  ### Fixed

@@ -1,6 +1,6 @@ cabal-version:   3.4 name:            monatone-version:         0.3.0.0+version:         0.4.0.0 synopsis:        Pure Haskell library for audio metadata parsing and writing description:   Monatone is a pure Haskell library for parsing and writing@@ -48,12 +48,16 @@                  Monatone.MP3.Writer                  Monatone.Metadata                  Monatone.OGG+                 Monatone.OGG.Writer                  Monatone.Types                  Monatone.Writer   other-modules:                  Paths_monatone   autogen-modules:                  Paths_monatone+  if !os(windows)+    build-depends: unix >= 2.8 && < 2.9+    cpp-options:   -DUSE_UNIX_FSYNC   hs-source-dirs:                  src   build-depends:@@ -117,6 +121,7 @@                  Test.IntegrationSpec                  Test.M4ASpec                  Test.MP3Spec+                 Test.OGGSpec                  Test.WriterSpec   hs-source-dirs:                  test@@ -124,6 +129,7 @@                  base,                  monatone,                  QuickCheck           >= 2.14    && < 2.17,+                 base64-bytestring,                  bytestring,                  containers,                  directory,

@@ -15,6 +15,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L import qualified Data.HashMap.Strict as HM+import Data.Maybe (listToMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE@@ -141,11 +142,12 @@   | t == blockTypePicture       = Picture   | otherwise                   = Reserved t --- | Parse StreamInfo block+-- | Parse StreamInfo block; a truncated block leaves metadata unchanged parseStreamInfo :: BS.ByteString -> Metadata -> Metadata-parseStreamInfo bs metadata = -  let lazyBs = L.fromStrict bs-  in runGet (parseStreamInfoGet metadata) lazyBs+parseStreamInfo bs metadata =+  case runGetOrFail (parseStreamInfoGet metadata) (L.fromStrict bs) of+    Left _ -> metadata+    Right (_, _, result) -> result  parseStreamInfoGet :: Metadata -> Get Metadata parseStreamInfoGet metadata = do@@ -195,16 +197,20 @@                (fromIntegral b2 `shiftL` 8) .|.                 fromIntegral b3 --- | Parse Vorbis Comments block+-- | Parse Vorbis Comments block; a truncated or malformed block (e.g. a+-- lying vendor or comment length) leaves metadata unchanged parseVorbisCommentsBlock :: BS.ByteString -> Metadata -> Metadata-parseVorbisCommentsBlock bs metadata = -  let lazyBs = L.fromStrict bs-  in runGet (parseVorbisCommentsGet metadata) lazyBs+parseVorbisCommentsBlock bs metadata =+  case runGetOrFail (parseVorbisCommentsGet metadata) (L.fromStrict bs) of+    Left _ -> metadata+    Right (_, _, result) -> result  -- | Parse Vorbis Comments (for compatibility) parseVorbisComments :: L.ByteString -> Metadata -> Parser Metadata-parseVorbisComments bs metadata = -  return $ runGet (parseVorbisCommentsGet metadata) bs+parseVorbisComments bs metadata =+  case runGetOrFail (parseVorbisCommentsGet metadata) bs of+    Left _ -> throwError $ CorruptedFile "Malformed Vorbis comment block"+    Right (_, _, result) -> return result  -- | Parse Vorbis Comments using Get monad parseVorbisCommentsGet :: Metadata -> Get Metadata@@ -219,45 +225,47 @@      -- Read each comment   comments <- parseCommentList (fromIntegral numComments)-  -  -- Convert to HashMap for efficient lookup-  let tagMap = HM.fromList comments-  ++  -- Vorbis comments may repeat a key (e.g. several ARTIST entries); keep+  -- every value. The scalar metadata fields take the first one.+  let tagMap = HM.fromListWith (flip (<>)) [(k, [v]) | (k, v) <- comments]+      firstOf key = HM.lookup key tagMap >>= listToMaybe+   -- Extract standard fields   return $ metadata-    { title = HM.lookup "TITLE" tagMap-    , artist = HM.lookup "ARTIST" tagMap-    , album = HM.lookup "ALBUM" tagMap-    , albumArtist = HM.lookup "ALBUMARTIST" tagMap-    , year = (HM.lookup "YEAR" tagMap >>= readInt)-             <|> (HM.lookup "DATE" tagMap >>= extractYearFromDate)-    , date = HM.lookup "DATE" tagMap-    , comment = HM.lookup "COMMENT" tagMap-    , genre = HM.lookup "GENRE" tagMap-    , trackNumber = HM.lookup "TRACKNUMBER" tagMap >>= readInt-    , totalTracks = HM.lookup "TRACKTOTAL" tagMap >>= readInt-    , discNumber = HM.lookup "DISCNUMBER" tagMap >>= readInt-    , totalDiscs = HM.lookup "DISCTOTAL" tagMap >>= readInt-    , releaseCountry = HM.lookup "RELEASECOUNTRY" tagMap-    , recordLabel = HM.lookup "LABEL" tagMap-    , catalogNumber = HM.lookup "CATALOGNUMBER" tagMap-    , barcode = HM.lookup "BARCODE" tagMap-    , releaseStatus = HM.lookup "RELEASESTATUS" tagMap-    , releaseType = HM.lookup "RELEASETYPE" tagMap+    { title = firstOf "TITLE"+    , artist = firstOf "ARTIST"+    , album = firstOf "ALBUM"+    , albumArtist = firstOf "ALBUMARTIST"+    , year = (firstOf "YEAR" >>= readInt)+             <|> (firstOf "DATE" >>= extractYearFromDate)+    , date = firstOf "DATE"+    , comment = firstOf "COMMENT"+    , genre = firstOf "GENRE"+    , trackNumber = firstOf "TRACKNUMBER" >>= readInt+    , totalTracks = firstOf "TRACKTOTAL" >>= readInt+    , discNumber = firstOf "DISCNUMBER" >>= readInt+    , totalDiscs = firstOf "DISCTOTAL" >>= readInt+    , releaseCountry = firstOf "RELEASECOUNTRY"+    , recordLabel = firstOf "LABEL"+    , catalogNumber = firstOf "CATALOGNUMBER"+    , barcode = firstOf "BARCODE"+    , releaseStatus = firstOf "RELEASESTATUS"+    , releaseType = firstOf "RELEASETYPE"     , musicBrainzIds = MusicBrainzIds-      { mbTrackId = HM.lookup "MUSICBRAINZ_RELEASETRACKID" tagMap-      , mbRecordingId = HM.lookup "MUSICBRAINZ_TRACKID" tagMap-      , mbReleaseId = HM.lookup "MUSICBRAINZ_ALBUMID" tagMap-      , mbReleaseGroupId = HM.lookup "MUSICBRAINZ_RELEASEGROUPID" tagMap-      , mbArtistId = HM.lookup "MUSICBRAINZ_ARTISTID" tagMap-      , mbAlbumArtistId = HM.lookup "MUSICBRAINZ_ALBUMARTISTID" tagMap-      , mbWorkId = HM.lookup "MUSICBRAINZ_WORKID" tagMap-      , mbDiscId = HM.lookup "MUSICBRAINZ_DISCID" tagMap+      { mbTrackId = firstOf "MUSICBRAINZ_RELEASETRACKID"+      , mbRecordingId = firstOf "MUSICBRAINZ_TRACKID"+      , mbReleaseId = firstOf "MUSICBRAINZ_ALBUMID"+      , mbReleaseGroupId = firstOf "MUSICBRAINZ_RELEASEGROUPID"+      , mbArtistId = firstOf "MUSICBRAINZ_ARTISTID"+      , mbAlbumArtistId = firstOf "MUSICBRAINZ_ALBUMARTISTID"+      , mbWorkId = firstOf "MUSICBRAINZ_WORKID"+      , mbDiscId = firstOf "MUSICBRAINZ_DISCID"       }-    , acoustidFingerprint = HM.lookup "ACOUSTID_FINGERPRINT" tagMap <|>-                           HM.lookup "acoustid_fingerprint" tagMap-    , acoustidId = HM.lookup "ACOUSTID_ID" tagMap <|>-                  HM.lookup "acoustid_id" tagMap+    , acoustidFingerprint = firstOf "ACOUSTID_FINGERPRINT" <|>+                           firstOf "acoustid_fingerprint"+    , acoustidId = firstOf "ACOUSTID_ID" <|>+                  firstOf "acoustid_id"     , rawTags = tagMap     }   where@@ -339,9 +347,14 @@           -- Check if this is a Picture block           if blockType header == Picture             then do-              -- Parse the picture block with full data+              -- Parse the picture block with full data; if it is corrupt,+              -- keep scanning - a later Picture block may still parse               pictureData <- BS.hGet handle (fromIntegral $ blockLength header)-              return $ parsePictureBlockFull pictureData+              case parsePictureBlockFull pictureData of+                Just art -> return $ Just art+                Nothing+                  | isLast header -> return Nothing+                  | otherwise -> findPictureBlock handle             else do               -- Skip this block and continue               hSeek handle RelativeSeek (fromIntegral $ blockLength header)

@@ -1,12 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TupleSections #-}  module Monatone.FLAC.Writer   ( writeFLACMetadata   , WriteError(..)   , Writer+    -- * Shared with the OGG writer (Vorbis comments are common to both)+  , generateVorbisComments+  , renderPictureData   ) where  import Control.Applicative ((<|>))@@ -19,7 +21,7 @@ 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.Maybe (fromMaybe, listToMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE@@ -47,12 +49,11 @@ bufferSize = 65536  -- | Write metadata to FLAC file incrementally--- Takes optional AlbumArt separately since Metadata only stores AlbumArtInfo-writeFLACMetadata :: Metadata -> Maybe AlbumArt -> OsPath -> Writer ()-writeFLACMetadata metadata maybeAlbumArt filePath = do+writeFLACMetadata :: Metadata -> AlbumArtUpdate -> OsPath -> Writer ()+writeFLACMetadata metadata artUpdate filePath = do   -- Open file in read/write mode   result <- liftIO $ tryIO $ withBinaryFile filePath ReadWriteMode $ \handle -> do-    runExceptT $ writeFLACHandleIncremental metadata maybeAlbumArt handle+    runExceptT $ writeFLACHandleIncremental metadata artUpdate handle   case result of     Left (e :: IOException) -> throwError $ WriteIOError $ T.pack $ show e     Right (Left err) -> throwError err@@ -62,8 +63,8 @@     tryIO action = catch (Right <$> action) (return . Left)  -- | Write FLAC metadata using a file handle incrementally-writeFLACHandleIncremental :: Metadata -> Maybe AlbumArt -> Handle -> Writer ()-writeFLACHandleIncremental metadata maybeAlbumArt handle = do+writeFLACHandleIncremental :: Metadata -> AlbumArtUpdate -> Handle -> Writer ()+writeFLACHandleIncremental metadata artUpdate handle = do   -- Verify FLAC signature   liftIO $ hSeek handle AbsoluteSeek 0   sig <- liftIO $ BS.hGet handle 4@@ -74,13 +75,18 @@   -- Extract original STREAMINFO block for preservation (it's always first, 34 bytes)   streamInfoHeader <- liftIO $ BS.hGet handle 4   streamInfoData <- liftIO $ BS.hGet handle 34+  if BS.length streamInfoHeader < 4 || BS.length streamInfoData < 34+    then throwError $ CorruptedWrite "File too small for STREAMINFO block"+    else pure ()   let originalStreamInfo = L.fromStrict $ BS.append streamInfoHeader streamInfoData -  -- Find where the audio data starts, collecting blocks we must keep verbatim-  (audioDataOffset, preservedBlocks) <- scanMetadataBlocks handle 4  -- Start after "fLaC"+  -- Find where the audio data starts, collecting blocks we must keep+  -- verbatim; existing PICTURE blocks are kept when the art is unchanged+  let keepPictures = artUpdate == KeepExistingArt+  (audioDataOffset, preservedBlocks, originalVendor) <- scanMetadataBlocks handle 4 keepPictures    -- Generate new metadata blocks with preserved STREAMINFO-  newMetadataBlocks <- generateMetadataBlocks metadata maybeAlbumArt originalStreamInfo preservedBlocks+  newMetadataBlocks <- generateMetadataBlocks metadata artUpdate originalStreamInfo preservedBlocks originalVendor   let newMetadataSize = fromIntegral $ L.length newMetadataBlocks      -- Get file size@@ -112,34 +118,55 @@     -- Then delete extra space     deleteBytesInFile handle bytesToDelete (4 + newMetadataSize) --- | 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 []+-- | Walk the metadata blocks: return the audio data offset, the raw bytes+-- of every block we must carry over verbatim (SEEKTABLE, APPLICATION,+-- CUESHEET, unknown types - and PICTURE blocks when keepPictures is set),+-- and the original Vorbis vendor string. STREAMINFO and VORBIS_COMMENT+-- are regenerated; PADDING is dropped.+scanMetadataBlocks :: Handle -> Int -> Bool -> Writer (Int, [L.ByteString], Maybe BS.ByteString)+scanMetadataBlocks handle startOffset keepPictures = go startOffset [] Nothing   where-    regenerated = [0, 1, 4, 6]  -- STREAMINFO, PADDING, VORBIS_COMMENT, PICTURE+    -- STREAMINFO, PADDING, VORBIS_COMMENT, and PICTURE unless kept+    regenerated = [0, 1, 4] ++ [6 | not keepPictures] -    go currentOffset acc = do+    go :: Int -> [L.ByteString] -> Maybe BS.ByteString -> Writer (Int, [L.ByteString], Maybe BS.ByteString)+    go currentOffset acc vendor = do       liftIO $ hSeek handle AbsoluteSeek (fromIntegral currentOffset)       headerBytes <- liftIO $ BS.hGet handle 4       if BS.length headerBytes < 4-        then return (currentOffset, reverse acc)+        then return (currentOffset, reverse acc, vendor)         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+          (acc', vendor') <- if blockType header `elem` regenerated+            then do+              -- Remember the original encoder's vendor string so a tag+              -- update does not claim the file was encoded by us+              newVendor <- if blockType header == 4 && vendor == Nothing+                then do+                  blockData <- liftIO $ BS.hGet handle blockSize+                  return $ extractVendor blockData+                else return vendor+              return (acc, newVendor)             else do               blockData <- liftIO $ BS.hGet handle blockSize+              if BS.length blockData < blockSize+                then throwError $ CorruptedWrite "Truncated metadata block"+                else pure ()               -- Last-block flag is recomputed when the blocks are reassembled-              return $ L.fromStrict (headerBytes <> blockData) : acc+              return (L.fromStrict (headerBytes <> blockData) : acc, vendor)           if isLast header-            then return (nextOffset, reverse acc')-            else go nextOffset acc'+            then return (nextOffset, reverse acc', vendor')+            else go nextOffset acc' vendor' +    extractVendor blockData+      | BS.length blockData < 4 = Nothing+      | otherwise =+          let vendorLen = fromIntegral $ runGet getWord32le (L.fromStrict (BS.take 4 blockData))+              vendorBytes = BS.take vendorLen (BS.drop 4 blockData)+          in if BS.length vendorBytes == vendorLen then Just vendorBytes else Nothing+ -- | Insert bytes into file at given offset insertBytesInFile :: Handle -> Int -> Int -> Writer () insertBytesInFile handle size offset = do@@ -232,22 +259,15 @@      return $ BlockHeader lastFlag bType len --- | Extract the original STREAMINFO block (already read from handle)-_extractStreamInfoBlock :: L.ByteString -> Writer L.ByteString-_extractStreamInfoBlock blockData = do-  if L.length blockData < 38  -- 4 byte header + 34 byte STREAMINFO-    then throwError $ CorruptedWrite "File too small for STREAMINFO block"-    else return $ L.take 38 blockData  -- Include header + data- -- | 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-  pictureBlocks <- case maybeAlbumArt of-    Nothing -> return []-    Just albumArt -> (: []) <$> generatePictureBlock albumArt False+-- the final block only. Kept pictures travel in preservedBlocks.+generateMetadataBlocks :: Metadata -> AlbumArtUpdate -> L.ByteString -> [L.ByteString] -> Maybe BS.ByteString -> Writer L.ByteString+generateMetadataBlocks metadata artUpdate originalStreamInfo preservedBlocks originalVendor = do+  vorbisBlock <- generateVorbisCommentBlock metadata originalVendor False+  pictureBlocks <- case artUpdate of+    SetAlbumArt albumArt -> (: []) <$> generatePictureBlock albumArt False+    _ -> return []    let blocks = [originalStreamInfo] ++ preservedBlocks ++ [vorbisBlock] ++ pictureBlocks   return $ L.concat $ markLastBlock blocks@@ -261,16 +281,16 @@         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 = T.pack $ "Monatone " ++ showVersion version-  let vendorBytes = TE.encodeUtf8 vendor+-- | Generate Vorbis comment block, keeping the original vendor string+-- when there is one+generateVorbisCommentBlock :: Metadata -> Maybe BS.ByteString -> Bool -> Writer L.ByteString+generateVorbisCommentBlock metadata originalVendor isLastBlock = do+  let defaultVendor = TE.encodeUtf8 $ T.pack $ "Monatone " ++ showVersion version+  let vendorBytes = fromMaybe defaultVendor originalVendor   let vendorLenBytes = runPut $ putWord32le $ fromIntegral $ BS.length vendorBytes      -- Create comment list-  comments <- generateVorbisComments metadata+  let comments = generateVorbisComments metadata   let commentCount = length comments   let commentCountBytes = runPut $ putWord32le $ fromIntegral commentCount   @@ -284,59 +304,68 @@   let encodedComments = L.concat $ map encodeComment comments      -- Build complete Vorbis comment data-  let vorbisData = vendorLenBytes <> L.fromStrict vendorBytes <> +  let vorbisData = vendorLenBytes <> L.fromStrict vendorBytes <>                   commentCountBytes <> encodedComments-  +   -- Create block header-  let blockLen = fromIntegral $ L.length vorbisData :: Word32   let headerByte = if isLastBlock then 0x84 else 0x04  -- Block type 4 = Vorbis comment-  let header = runPut $ do-        putWord8 headerByte-        -- Write 24-bit length-        putWord8 $ fromIntegral $ (blockLen `shiftR` 16) .&. 0xFF-        putWord8 $ fromIntegral $ (blockLen `shiftR` 8) .&. 0xFF-        putWord8 $ fromIntegral $ blockLen .&. 0xFF-  +  header <- blockHeader headerByte vorbisData   return $ header <> vorbisData --- | 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 = return $ mappedComments ++ preservedComments+-- | Generate Vorbis comments from metadata. Every field the parser maps+-- is written back, and unmapped comments in rawTags are carried over so+-- an update never drops tags it does not understand. (Album art is not+-- included: FLAC stores it in a PICTURE block, OGG appends its own+-- METADATA_BLOCK_PICTURE comment.)+generateVorbisComments :: Metadata -> [(Text, Text)]+generateVorbisComments metadata = mappedComments ++ preservedComments   where     mbIds = musicBrainzIds metadata     showT = T.pack . show -    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+    -- A scalar field is the first value of a possibly multi-valued key.+    -- If the field still matches what was parsed, write every stored+    -- value back (several ARTIST comments survive an unrelated update);+    -- if it was edited, the edit replaces the whole set.+    multi key field = case field of+      Nothing -> []+      Just v ->+        let stored = HM.lookupDefault [] key (rawTags metadata)+        in if listToMaybe stored == Just v+             then [(key, s) | s <- stored]+             else [(key, v)]++    single key = maybe [] (\v -> [(key, v)])++    mappedComments = concat+      [ multi "TITLE" (title metadata)+      , multi "ARTIST" (artist metadata)+      , multi "ALBUM" (album metadata)+      , multi "ALBUMARTIST" (albumArtist metadata)+      , single "TRACKNUMBER" (showT <$> trackNumber metadata)+      , single "TRACKTOTAL" (showT <$> totalTracks metadata)+      , single "DISCNUMBER" (showT <$> discNumber metadata)+      , single "DISCTOTAL" (showT <$> totalDiscs metadata)+      , single "DATE" (date metadata <|> (showT <$> year metadata))+      , multi "GENRE" (genre metadata)+      , multi "COMMENT" (comment metadata)+      , multi "PUBLISHER" (publisher metadata)+      , single "BARCODE" (barcode metadata)+      , single "CATALOGNUMBER" (catalogNumber metadata)+      , multi "LABEL" (recordLabel metadata)+      , single "RELEASECOUNTRY" (releaseCountry metadata)+      , single "RELEASESTATUS" (releaseStatus metadata)+      , single "RELEASETYPE" (releaseType metadata)+      , single "MUSICBRAINZ_RELEASETRACKID" (mbTrackId mbIds)+      , single "MUSICBRAINZ_TRACKID" (mbRecordingId mbIds)+      , single "MUSICBRAINZ_ALBUMID" (mbReleaseId mbIds)+      , single "MUSICBRAINZ_RELEASEGROUPID" (mbReleaseGroupId mbIds)+      , multi "MUSICBRAINZ_ARTISTID" (mbArtistId mbIds)+      , multi "MUSICBRAINZ_ALBUMARTISTID" (mbAlbumArtistId mbIds)+      , single "MUSICBRAINZ_WORKID" (mbWorkId mbIds)+      , single "MUSICBRAINZ_DISCID" (mbDiscId mbIds)+      , single "ACOUSTID_FINGERPRINT" (acoustidFingerprint metadata)+      , single "ACOUSTID_ID" (acoustidId metadata)       ]      -- Keys the mapped fields own (whether or not they are set right now):@@ -357,40 +386,50 @@      preservedComments =       [ (key, value)-      | (key, value) <- HM.toList (rawTags metadata)+      | (key, values) <- HM.toList (rawTags metadata)       , T.toUpper key `notElem` handledKeys+      , value <- values       ] --- | Generate Picture block for album art-generatePictureBlock :: AlbumArt -> Bool -> Writer L.ByteString-generatePictureBlock art isLastBlock = do+-- | Render the body of a FLAC PICTURE block (also the payload OGG encodes+-- as a base64 METADATA_BLOCK_PICTURE comment)+renderPictureData :: AlbumArt -> L.ByteString+renderPictureData art =   let mimeBytes = TE.encodeUtf8 $ albumArtMimeType art       descBytes = TE.encodeUtf8 $ albumArtDescription art       imageData = albumArtData art--      -- Build picture data according to FLAC spec-      pictureData = runPut $ do-        putWord32be $ fromIntegral $ albumArtPictureType art  -- Picture type-        putWord32be $ fromIntegral $ BS.length mimeBytes      -- MIME type length-        putByteString mimeBytes                               -- MIME type-        putWord32be $ fromIntegral $ BS.length descBytes      -- Description length-        putByteString descBytes                               -- Description-        putWord32be 0                                         -- Width (0 = unknown)-        putWord32be 0                                         -- Height (0 = unknown)-        putWord32be 0                                         -- Color depth (0 = unknown)-        putWord32be 0                                         -- Number of colors (0 = unknown)-        putWord32be $ fromIntegral $ BS.length imageData      -- Picture data length-        putByteString imageData                               -- Picture data+  in runPut $ do+       putWord32be $ fromIntegral $ albumArtPictureType art  -- Picture type+       putWord32be $ fromIntegral $ BS.length mimeBytes      -- MIME type length+       putByteString mimeBytes                               -- MIME type+       putWord32be $ fromIntegral $ BS.length descBytes      -- Description length+       putByteString descBytes                               -- Description+       putWord32be 0                                         -- Width (0 = unknown)+       putWord32be 0                                         -- Height (0 = unknown)+       putWord32be 0                                         -- Color depth (0 = unknown)+       putWord32be 0                                         -- Number of colors (0 = unknown)+       putWord32be $ fromIntegral $ BS.length imageData      -- Picture data length+       putByteString imageData                               -- Picture data -      blockLen = fromIntegral $ L.length pictureData :: Word32+-- | Generate Picture block for album art+generatePictureBlock :: AlbumArt -> Bool -> Writer L.ByteString+generatePictureBlock art isLastBlock = do+  let pictureData = renderPictureData art       headerByte = if isLastBlock then 0x86 else 0x06  -- Block type 6 = Picture -      -- Build block header-      header = runPut $ do-        putWord8 headerByte-        -- Write 24-bit length-        putWord8 $ fromIntegral $ (blockLen `shiftR` 16) .&. 0xFF-        putWord8 $ fromIntegral $ (blockLen `shiftR` 8) .&. 0xFF-        putWord8 $ fromIntegral $ blockLen .&. 0xFF-+  header <- blockHeader headerByte pictureData   return $ header <> pictureData++-- | Build a metadata block header, rejecting content that does not fit the+-- 24-bit length field (silently truncating it would corrupt the stream)+blockHeader :: Word8 -> L.ByteString -> Writer L.ByteString+blockHeader headerByte content = do+  let len = L.length content+  if len > 0xFFFFFF+    then throwError $ InvalidMetadata "Metadata block exceeds FLAC's 16MiB block size limit"+    else return $ runPut $ do+      putWord8 headerByte+      -- Write 24-bit length+      putWord8 $ fromIntegral $ (len `shiftR` 16) .&. 0xFF+      putWord8 $ fromIntegral $ (len `shiftR` 8) .&. 0xFF+      putWord8 $ fromIntegral $ len .&. 0xFF

@@ -36,8 +36,10 @@   } deriving (Show, Eq)  -- | Container atoms that have children+-- (stsd is handled separately: its children sit after a version/flags ++-- entry-count preamble that the generic container logic cannot skip) containerAtoms :: [BS.ByteString]-containerAtoms = ["moov", "udta", "trak", "mdia", "meta", "ilst", "stbl", "minf", "moof", "traf", "stsd"]+containerAtoms = ["moov", "udta", "trak", "mdia", "meta", "ilst", "stbl", "minf", "moof", "traf"]  -- | Parse M4A file parseM4A :: OsPath -> Parser Metadata@@ -93,18 +95,32 @@       let (size32, name) = runGet ((,) <$> getWord32be <*> getByteString 4) (L.fromStrict headerData)        -- Handle 64-bit size-      (actualSize, dataOffset) <- if size32 == 1+      sizeInfo <- if size32 == 1         then do           size64Data <- BS.hGet handle 8-          let size64 = runGet getWord64be (L.fromStrict size64Data)-          return (size64, offset + 16)+          if BS.length size64Data < 8+            then return Nothing  -- truncated inside the extended size field+            else do+              let size64 = runGet getWord64be (L.fromStrict size64Data)+              -- An extended size below the 16-byte header is malformed and+              -- would make the parse loop stand still or walk backwards+              return $ if size64 < 16 then Nothing else Just (size64, offset + 16)         else if size32 == 0           then do             -- Size extends to end of file             fileSize <- hFileSize handle-            return (fromIntegral (fileSize - offset), offset + 8)-        else return (fromIntegral size32, offset + 8)+            return $ Just (fromIntegral (fileSize - offset), offset + 8)+        else if size32 < 8+          then return Nothing  -- malformed: smaller than its own header+          else return $ Just (fromIntegral size32, offset + 8) +      case sizeInfo of+        Nothing -> return Nothing+        Just (actualSize, dataOffset) -> parseAtomBody handle offset name actualSize dataOffset++-- | Build the atom once its size has been validated+parseAtomBody :: Handle -> Integer -> BS.ByteString -> Word64 -> Integer -> IO (Maybe Atom)+parseAtomBody handle offset name actualSize dataOffset = do       -- Check if this is a container atom       -- Note: We'll determine if we need children during parsing       let isContainer = name `elem` containerAtoms@@ -163,26 +179,35 @@       case atomChildren ilstAtom of         Nothing -> return metadata         Just children -> do-          -- Parse each tag atom+          -- Parse each tag atom; repeated tags keep every value           tags <- mapM (parseTagAtom handle) children-          let tagMap = HM.fromList $ concat tags+          let tagMap = HM.fromListWith (flip (<>)) [(k, [v]) | (k, v) <- concat tags]            -- Parse album art info separately           artInfo <- extractAlbumArtInfo handle children            return $ (applyTags tagMap metadata) { albumArtInfo = artInfo } +-- | Read an atom's payload, clamped to what the file can actually hold so+-- a lying size field cannot trigger a huge up-front allocation+readAtomPayload :: Handle -> Atom -> IO BS.ByteString+readAtomPayload handle atom = do+  fileSize <- hFileSize handle+  let headerLen = atomDataOffset atom - atomOffset atom+      declared = fromIntegral (atomSize atom) - headerLen+      available = fileSize - atomDataOffset atom+      payloadSize = min declared available+  if payloadSize <= 0+    then return BS.empty+    else do+      hSeek handle AbsoluteSeek (atomDataOffset atom)+      BS.hGet handle (fromIntegral payloadSize)+ -- | Parse a single tag atom from ilst parseTagAtom :: Handle -> Atom -> IO [(Text, Text)] parseTagAtom handle atom = do-  hSeek handle AbsoluteSeek (atomDataOffset atom)-  let dataSize = fromIntegral (atomSize atom) - fromIntegral (atomDataOffset atom - atomOffset atom)--  if dataSize <= 0-    then return []-    else do-      atomData <- BS.hGet handle dataSize-      return $ parseTagData (atomName atom) atomData+  atomData <- readAtomPayload handle atom+  return $ parseTagData (atomName atom) atomData  -- | Parse tag data - handles special atoms differently parseTagData :: BS.ByteString -> BS.ByteString -> [(Text, Text)]@@ -300,52 +325,54 @@                   -- The remaining bytes should be data atom(s)               in parseDataAtoms (TE.encodeUtf8 key) afterName --- | Apply parsed tags to metadata-applyTags :: HM.HashMap Text Text -> Metadata -> Metadata+-- | Apply parsed tags to metadata; scalar fields take the first value of+-- multi-valued tags+applyTags :: HM.HashMap Text [Text] -> Metadata -> Metadata applyTags tags metadata = metadata-  { title = HM.lookup "\169nam" tags-  , artist = HM.lookup "\169ART" tags-  , album = HM.lookup "\169alb" tags-  , albumArtist = HM.lookup "aART" tags-  , trackNumber = HM.lookup "trkn:current" tags >>= readInt-  , totalTracks = HM.lookup "trkn:total" tags >>= readInt-  , discNumber = HM.lookup "disk:current" tags >>= readInt-  , totalDiscs = HM.lookup "disk:total" tags >>= readInt-  , date = HM.lookup "\169day" tags-  , year = HM.lookup "\169day" tags >>= extractYear-  , genre = HM.lookup "\169gen" tags-  , 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-  , musicBrainzIds = extractMusicBrainzIds tags-  , acoustidFingerprint = lookupFreeform "Acoustid Fingerprint" tags-  , acoustidId = lookupFreeform "Acoustid Id" tags+  { title = firstOf "\169nam"+  , artist = firstOf "\169ART"+  , album = firstOf "\169alb"+  , albumArtist = firstOf "aART"+  , trackNumber = firstOf "trkn:current" >>= readInt+  , totalTracks = firstOf "trkn:total" >>= readInt+  , discNumber = firstOf "disk:current" >>= readInt+  , totalDiscs = firstOf "disk:total" >>= readInt+  , date = firstOf "\169day"+  , year = firstOf "\169day" >>= extractYear+  , genre = firstOf "\169gen"+  , comment = firstOf "\169cmt"+  , publisher = firstOf "\169pub"+  , releaseCountry = lookupFreeform "MusicBrainz Album Release Country"+  , releaseStatus = lookupFreeform "MusicBrainz Album Status"+  , releaseType = lookupFreeform "MusicBrainz Album Type"+  , recordLabel = lookupFreeform "LABEL"+  , catalogNumber = lookupFreeform "CATALOGNUMBER"+  , barcode = lookupFreeform "BARCODE"+  , musicBrainzIds = extractMusicBrainzIds+  , acoustidFingerprint = lookupFreeform "Acoustid Fingerprint"+  , acoustidId = lookupFreeform "Acoustid Id"   , rawTags = tags   }   where+    firstOf key = HM.lookup key tags >>= listToMaybe+     extractYear dateText =       let yearStr = T.takeWhile (/= '-') dateText       in readInt yearStr      -- Helper to look up freeform tags with common mean prefix-    lookupFreeform :: Text -> HM.HashMap Text Text -> Maybe Text-    lookupFreeform name tagMap =-      HM.lookup ("----:com.apple.iTunes:" <> name) tagMap+    lookupFreeform :: Text -> Maybe Text+    lookupFreeform name = firstOf ("----:com.apple.iTunes:" <> name) -    extractMusicBrainzIds tagMap = MusicBrainzIds-      { mbTrackId = lookupFreeform "MusicBrainz Release Track Id" tagMap-      , mbRecordingId = lookupFreeform "MusicBrainz Track Id" tagMap-      , mbReleaseId = lookupFreeform "MusicBrainz Album Id" tagMap-      , mbReleaseGroupId = lookupFreeform "MusicBrainz Release Group Id" tagMap-      , mbArtistId = lookupFreeform "MusicBrainz Artist Id" tagMap-      , mbAlbumArtistId = lookupFreeform "MusicBrainz Album Artist Id" tagMap-      , mbWorkId = lookupFreeform "MusicBrainz Work Id" tagMap-      , mbDiscId = lookupFreeform "MusicBrainz Disc Id" tagMap+    extractMusicBrainzIds = MusicBrainzIds+      { mbTrackId = lookupFreeform "MusicBrainz Release Track Id"+      , mbRecordingId = lookupFreeform "MusicBrainz Track Id"+      , mbReleaseId = lookupFreeform "MusicBrainz Album Id"+      , mbReleaseGroupId = lookupFreeform "MusicBrainz Release Group Id"+      , mbArtistId = lookupFreeform "MusicBrainz Artist Id"+      , mbAlbumArtistId = lookupFreeform "MusicBrainz Album Artist Id"+      , mbWorkId = lookupFreeform "MusicBrainz Work Id"+      , mbDiscId = lookupFreeform "MusicBrainz Disc Id"       }  -- | Extract album art info from ilst children@@ -354,13 +381,8 @@   case listToMaybe $ filter (\a -> atomName a == "covr") children of     Nothing -> return Nothing     Just covrAtom -> do-      hSeek handle AbsoluteSeek (atomDataOffset covrAtom)-      let dataSize = fromIntegral (atomSize covrAtom) - fromIntegral (atomDataOffset covrAtom - atomOffset covrAtom)-      if dataSize <= 0-        then return Nothing-        else do-          atomData <- BS.hGet handle dataSize-          return $ parseAlbumArtInfo atomData+      atomData <- readAtomPayload handle covrAtom+      return $ parseAlbumArtInfo atomData  -- | Parse album art info (lightweight, no image data) parseAlbumArtInfo :: BS.ByteString -> Maybe AlbumArtInfo@@ -480,26 +502,29 @@            codecName = atomName entry -      -- 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-          , sampleRate = Just $ fromIntegral entrySampleRate-          }-        Just exts -> do-          -- Look for esds (AAC) or alac atoms-          let esdsAtom = listToMaybe $ filter (\a -> atomName a == "esds") exts-          let alacAtom = listToMaybe $ filter (\a -> atomName a == "alac") exts+          headerProps = emptyAudioProperties+            { channels = Just $ fromIntegral entryChannels+            , bitsPerSample = Just $ fromIntegral entrySampleSize+            , sampleRate = Just $ fromIntegral entrySampleRate+            } -          case (codecName, esdsAtom, alacAtom) of-            ("mp4a", Just esds, _) -> parseEsdsAtom handle esds entryChannels entrySampleSize entrySampleRate-            ("alac", _, Just alac) -> parseAlacAtom handle alac-            _ -> return $ emptyAudioProperties-              { channels = Just $ fromIntegral entryChannels-              , bitsPerSample = Just $ fromIntegral entrySampleSize-              , sampleRate = Just $ fromIntegral entrySampleRate-              }+      -- Extension atoms (esds, alac) follow the 28-byte AudioSampleEntry+      -- header; the generic container logic cannot see past that header,+      -- so parse them explicitly+      hSeek handle AbsoluteSeek (atomDataOffset entry + 28)+      let entryEnd = atomOffset entry + fromIntegral (atomSize entry)+      exts <- parseAtomsUntil handle entryEnd+      let esdsAtom = listToMaybe $ filter (\a -> atomName a == "esds") exts+          alacAtom = listToMaybe $ filter (\a -> atomName a == "alac") exts++      props <- case (codecName, esdsAtom, alacAtom) of+        -- The alac box carries the true bit depth/channels/sample rate;+        -- the sample entry header often claims 16-bit for 24-bit files+        ("alac", _, Just alac) -> do+          alacProps <- parseAlacAtom handle alac+          return $ if alacProps == emptyAudioProperties then headerProps else alacProps+        ("mp4a", Just esds, _) -> parseEsdsAtom handle esds entryChannels entrySampleSize entrySampleRate+        _ -> return headerProps       return props { codec = codecFromName codecName }  -- | Map an M4A sample-entry atom name to a codec@@ -523,23 +548,29 @@     }  -- | Parse ALAC atom for Apple Lossless info+-- Content layout after version/flags (4): frameLength (4),+-- compatibleVersion (1), bitDepth (1), pb/mb/kb (3), numChannels (1),+-- maxRun (2), maxFrameBytes (4), avgBitRate (4), sampleRate (4) parseAlacAtom :: Handle -> Atom -> IO AudioProperties parseAlacAtom handle alac = do   hSeek handle AbsoluteSeek (atomDataOffset alac)-  alacData <- BS.hGet handle 36+  alacData <- BS.hGet handle 28    if BS.length alacData < 28     then return emptyAudioProperties     else do-      -- Skip version/flags (4 bytes) + frameLength (4 bytes) + compatibleVersion (1 byte)       let alacSampleSize = BS.index alacData 9           alacChannels = BS.index alacData 13-          alacSampleRate = runGet getWord32be (L.fromStrict $ BS.take 4 $ BS.drop 20 alacData)+          alacBitRate = runGet getWord32be (L.fromStrict $ BS.take 4 $ BS.drop 20 alacData)+          alacSampleRate = runGet getWord32be (L.fromStrict $ BS.take 4 $ BS.drop 24 alacData)        return emptyAudioProperties         { channels = Just $ fromIntegral alacChannels         , bitsPerSample = Just $ fromIntegral alacSampleSize         , sampleRate = Just $ fromIntegral alacSampleRate+        , bitrate = if alacBitRate > 0+            then Just $ fromIntegral alacBitRate `div` 1000+            else Nothing         }  -- | Load album art from M4A file (full binary data for writing)@@ -557,13 +588,8 @@             case listToMaybe $ filter (\a -> atomName a == "covr") children of               Nothing -> return $ Right Nothing               Just covrAtom -> do-                hSeek handle AbsoluteSeek (atomDataOffset covrAtom)-                let dataSize = fromIntegral (atomSize covrAtom) - fromIntegral (atomDataOffset covrAtom - atomOffset covrAtom)-                if dataSize <= 0-                  then return $ Right Nothing-                  else do-                    atomData <- BS.hGet handle dataSize-                    return $ Right $ parseAlbumArtFull atomData+                atomData <- readAtomPayload handle covrAtom+                return $ Right $ parseAlbumArtFull atomData    case result of     Left err -> throwError err

@@ -18,7 +18,7 @@ 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.Maybe (fromMaybe, listToMaybe, maybeToList) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE@@ -42,8 +42,8 @@  -- | Write metadata to M4A file -- M4A writing requires rewriting the entire moov atom, so we use a temp file approach-writeM4AMetadata :: Metadata -> Maybe AlbumArt -> OsPath -> Writer ()-writeM4AMetadata metadata maybeAlbumArt filePath = do+writeM4AMetadata :: Metadata -> AlbumArtUpdate -> OsPath -> Writer ()+writeM4AMetadata metadata artUpdate filePath = do   result <- liftIO $ tryIO $ do     -- Create temp file     withSystemTempFile "monatone-m4a.tmp" $ \tmpPath tmpHandle -> do@@ -52,7 +52,7 @@        -- Copy file with updated metadata       runExceptT $ do-        copyM4AWithMetadata filePath tmpOsPath metadata maybeAlbumArt+        copyM4AWithMetadata filePath tmpOsPath metadata artUpdate         -- Copy temp file back to original         liftIO $ copyFileContents tmpOsPath filePath @@ -80,8 +80,8 @@           copyLoop srcH dstH  -- | Copy M4A file with updated metadata-copyM4AWithMetadata :: OsPath -> OsPath -> Metadata -> Maybe AlbumArt -> Writer ()-copyM4AWithMetadata srcPath dstPath metadata maybeAlbumArt = do+copyM4AWithMetadata :: OsPath -> OsPath -> Metadata -> AlbumArtUpdate -> Writer ()+copyM4AWithMetadata srcPath dstPath metadata artUpdate = do   -- Parse source file to get atom structure   atoms <- liftIO $ withBinaryFile srcPath ReadMode parseTopLevelAtoms @@ -90,12 +90,12 @@     Nothing -> throwError $ CorruptedWrite "No moov atom found"     Just (moovOffset, moovSize) -> do       -- Generate new ilst atom data-      ilstData <- generateIlstData metadata maybeAlbumArt+      ilstData <- generateIlstData metadata artUpdate        -- Write to destination       writeResult <- liftIO $ withBinaryFile srcPath ReadMode $ \srcHandle -> do         withBinaryFile dstPath WriteMode $ \dstHandle -> do-          runExceptT $ rewriteM4AFile srcHandle dstHandle atoms moovOffset moovSize ilstData+          runExceptT $ rewriteM4AFile srcHandle dstHandle atoms moovOffset moovSize ilstData artUpdate        either throwError return writeResult @@ -125,20 +125,29 @@               let size32 = readWord32BE $ BS.take 4 header                   name = BS.take 4 $ BS.drop 4 header -              actualSize <- if size32 == 1+              maybeSize <- if size32 == 1                 then do                   sizeData <- BS.hGet h 8-                  return $ readWord64BE sizeData-                else return $ fromIntegral size32+                  return $ if BS.length sizeData < 8 || readWord64BE sizeData < 16+                    then Nothing  -- truncated or malformed extended size+                    else Just $ readWord64BE sizeData+                else if size32 == 0+                  then return $ Just $ fromIntegral (endPos - pos)  -- extends to EOF+                else if size32 < 8+                  then return Nothing  -- malformed: smaller than its own header+                else return $ Just $ fromIntegral size32 -              let atomInfo = AtomInfo-                    { aiOffset = pos-                    , aiSize = actualSize-                    , aiName = name-                    }+              case maybeSize of+                Nothing -> return $ reverse acc  -- stop on malformed atom+                Just actualSize -> do+                  let atomInfo = AtomInfo+                        { aiOffset = pos+                        , aiSize = actualSize+                        , aiName = name+                        } -              hSeek h AbsoluteSeek (pos + fromIntegral actualSize)-              parseAtomsLoop h endPos (atomInfo : acc)+                  hSeek h AbsoluteSeek (pos + fromIntegral actualSize)+                  parseAtomsLoop h endPos (atomInfo : acc)  -- | Find moov atom findMoovAtom :: [AtomInfo] -> Maybe (Integer, Word64)@@ -147,8 +156,8 @@   [] -> Nothing  -- | Rewrite M4A file with new metadata-rewriteM4AFile :: Handle -> Handle -> [AtomInfo] -> Integer -> Word64 -> L.ByteString -> Writer ()-rewriteM4AFile srcHandle dstHandle atoms moovOffset moovSize newIlstData = do+rewriteM4AFile :: Handle -> Handle -> [AtomInfo] -> Integer -> Word64 -> L.ByteString -> AlbumArtUpdate -> Writer ()+rewriteM4AFile srcHandle dstHandle atoms moovOffset moovSize newIlstData artUpdate = do   -- Copy all atoms before moov   liftIO $ copyBeforeMoov srcHandle dstHandle atoms moovOffset @@ -157,10 +166,17 @@     hSeek srcHandle AbsoluteSeek moovOffset     moovData <- BS.hGet srcHandle (fromIntegral moovSize) +    -- When keeping existing art, carry the covr atom(s) from the old+    -- ilst over verbatim+    let keptCovr = case artUpdate of+          KeepExistingArt -> extractCovrAtoms (BS.drop 8 moovData)+          _ -> L.empty+        fullIlstData = newIlstData <> keptCovr+     -- 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+    let newMoovData = L.toStrict $ rebuildMoovAtom moovData fullIlstData         delta = toInteger (BS.length newMoovData) - toInteger moovSize         oldMoovEnd = moovOffset + fromIntegral moovSize     BS.hPut dstHandle $ adjustChunkOffsets delta oldMoovEnd newMoovData@@ -168,6 +184,40 @@   -- Copy all atoms after moov   liftIO $ copyAfterMoov srcHandle dstHandle moovOffset moovSize +-- | Extract the raw covr atom(s) from a moov atom's content by walking+-- udta > meta (skipping its version/flags) > ilst+extractCovrAtoms :: ByteString -> L.ByteString+extractCovrAtoms moovContent =+  case findChildAtom "udta" moovContent of+    Nothing -> L.empty+    Just udtaContent -> case findChildAtom "meta" udtaContent of+      Nothing -> L.empty+      Just metaContent -> case findChildAtom "ilst" (BS.drop 4 metaContent) of+        Nothing -> L.empty+        Just ilstContent -> L.fromStrict $ BS.concat (collectAtoms "covr" ilstContent)+  where+    -- Walk sibling atoms; return the named atom's content+    findChildAtom name bs = listToMaybe [c | (n, _, c) <- walkAtoms bs, n == name]++    -- Walk sibling atoms; return the named atoms verbatim (with header)+    collectAtoms name bs = [raw | (n, raw, _) <- walkAtoms bs, n == name]++    walkAtoms bs+      | BS.length bs < 8 = []+      | otherwise =+          let size32 = readWord32BE $ BS.take 4 bs+              name = BS.take 4 $ BS.drop 4 bs+              (headerLen, atomSize)+                | size32 == 0 = (8, BS.length bs)  -- atom extends to end+                | size32 == 1 && BS.length bs >= 16 =+                    (16, fromIntegral $ readWord64BE $ BS.take 8 $ BS.drop 8 bs)+                | otherwise = (8, fromIntegral size32)+          in if atomSize < headerLen || atomSize > BS.length bs+             then []  -- corrupt size; stop walking+             else+               let (atom, rest) = BS.splitAt atomSize bs+               in (name, atom, BS.drop headerLen atom) : walkAtoms rest+ -- | Copy atoms before moov copyBeforeMoov :: Handle -> Handle -> [AtomInfo] -> Integer -> IO () copyBeforeMoov srcHandle dstHandle atoms moovOffset = do@@ -200,8 +250,11 @@       | otherwise = do           let chunkSize = min 65536 n           chunk <- BS.hGet srcHandle chunkSize-          BS.hPut dstHandle chunk-          go (n - BS.length chunk)+          if BS.null chunk+            then return ()  -- premature EOF; nothing more to copy+            else do+              BS.hPut dstHandle chunk+              go (n - BS.length chunk)  -- | Rebuild moov atom with new ilst data rebuildMoovAtom :: ByteString -> L.ByteString -> L.ByteString@@ -290,14 +343,19 @@           let size32 = readWord32BE $ BS.take 4 remaining               name = BS.take 4 $ BS.drop 4 remaining -              actualSize = if size32 == 1-                then fromIntegral $ readWord64BE $ BS.take 8 $ BS.drop 8 remaining-                else fromIntegral size32+              actualSize+                | size32 == 1 && BS.length remaining >= 16 =+                    fromIntegral $ readWord64BE $ BS.take 8 $ BS.drop 8 remaining+                | size32 == 0 = BS.length remaining  -- extends to end+                | otherwise = fromIntegral size32                atomData = L.fromStrict $ BS.take actualSize remaining               nextRemaining = BS.drop actualSize remaining -          in if name == "udta"+          in if actualSize < 8+             -- Malformed size would stall the loop; keep the rest verbatim+             then acc <> L.fromStrict remaining+             else if name == "udta"              then go nextRemaining acc  -- Skip udta atom              else go nextRemaining (acc <> atomData)  -- Keep other atoms @@ -305,8 +363,8 @@ -- | 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+generateIlstData :: Metadata -> AlbumArtUpdate -> Writer L.ByteString+generateIlstData metadata artUpdate = do   let tags = concat         [ renderTextTag "\169nam" <$> maybeToList (title metadata)         , renderTextTag "\169ART" <$> maybeToList (artist metadata)@@ -318,7 +376,10 @@         , renderTextTag "\169pub" <$> maybeToList (publisher metadata)         , maybeToList $ renderTrackDiskTag "trkn" (trackNumber metadata) (totalTracks metadata)         , maybeToList $ renderTrackDiskTag "disk" (discNumber metadata) (totalDiscs metadata)-        , renderCoverTag <$> maybeToList maybeAlbumArt+        -- Kept art is carried over verbatim by the moov rewrite instead+        , case artUpdate of+            SetAlbumArt art -> [renderCoverTag art]+            _ -> []         -- Freeform tags for MusicBrainz-style metadata         , renderFreeformTag "LABEL" <$> maybeToList (recordLabel metadata)         , renderFreeformTag "CATALOGNUMBER" <$> maybeToList (catalogNumber metadata)@@ -334,7 +395,8 @@         -- Unmapped tags carried over from the source file         , concat             [ renderPreservedTag key value-            | (key, value) <- HM.toList (rawTags metadata)+            | (key, values) <- HM.toList (rawTags metadata)+            , value <- values             ]         ] @@ -396,16 +458,19 @@       dataAtom = renderDataAtom 1 textData  -- Type 1 = UTF-8   in renderAtom name dataAtom --- | Render track/disk number tag+-- | Render track/disk number tag. iTunes convention: trkn carries a+-- trailing reserved word (8 bytes), disk does not (6 bytes). Values are+-- clamped to the 16-bit field rather than silently wrapping. renderTrackDiskTag :: ByteString -> Maybe Int -> Maybe Int -> Maybe L.ByteString renderTrackDiskTag name (Just current) maybeTotal =   let total = fromMaybe 0 maybeTotal+      clamp16 n = fromIntegral (max 0 (min 0xFFFF n))       trackData = runPut $ do         putWord16be 0  -- reserved-        putWord16be (fromIntegral current)-        putWord16be (fromIntegral total)-        putWord16be 0  -- reserved-      dataAtom = renderDataAtom 0 (L.toStrict trackData)  -- Type 0 = implicit+        putWord16be (clamp16 current)+        putWord16be (clamp16 total)+      trailing = if name == "trkn" then runPut (putWord16be 0) else L.empty+      dataAtom = renderDataAtom 0 (L.toStrict (trackData <> trailing))  -- Type 0 = implicit   in Just $ renderAtom name dataAtom renderTrackDiskTag _ Nothing _ = Nothing 

@@ -4,6 +4,7 @@ module Monatone.MP3   ( parseMP3   , loadAlbumArtMP3+  , extractRawFrames   ) where  import Control.Applicative ((<|>))@@ -11,9 +12,10 @@ import Control.Monad.Except (throwError) import Data.Binary.Get import Data.Bits+import Data.Char (isDigit) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, listToMaybe) import Data.Word import System.IO (Handle, IOMode(..), hSeek, SeekMode(..), hFileSize, hTell) import System.OsPath@@ -80,38 +82,61 @@     [b1, b2, b3, b4] -> (b1 `shiftL` 21) .|. (b2 `shiftL` 14) .|. (b3 `shiftL` 7) .|. b4     _ -> 0  -- Should not happen with BS.take 4, but handle gracefully +-- | Reverse ID3v2 unsynchronisation (0xFF 0x00 -> 0xFF)+removeUnsync :: BS.ByteString -> BS.ByteString+removeUnsync bs = BS.pack (go (BS.unpack bs))+  where+    go (0xFF : 0x00 : rest) = 0xFF : go rest+    go (b : rest) = b : go rest+    go [] = []++-- | Skip the ID3v2 extended header if present. In v2.4 its size field is a+-- syncsafe integer that includes itself; in v2.3 it is a plain 32-bit+-- integer that excludes itself+skipExtendedHeader :: Word8 -> BS.ByteString -> BS.ByteString+skipExtendedHeader version bs+  | BS.length bs < 4 = bs+  | version >= 4 = BS.drop (max 4 (fromIntegral (parseSynchsafeInt bs))) bs+  | otherwise = BS.drop (4 + fromIntegral (runGet getWord32be (L.fromStrict (BS.take 4 bs)))) bs+ -- | Parse ID3v2 tag data parseID3v2Tag :: Word8 -> Word8 -> BS.ByteString -> Metadata -> Metadata-parseID3v2Tag version _flags tagData metadata =-  let frames = parseID3v2Frames version (L.fromStrict tagData)-      tagMap = HM.fromList frames+parseID3v2Tag version flags rawTagData metadata =+  let unsynced = if flags .&. 0x80 /= 0 then removeUnsync rawTagData else rawTagData+      tagData = if flags .&. 0x40 /= 0 then skipExtendedHeader version unsynced else unsynced+      frames = if version >= 3+        then concatMap classifyFrame (extractRawFramesFromPayload version tagData)+        else parseID3v22Frames (L.fromStrict tagData)+      -- Repeated frames keep every value; scalar fields take the first+      tagMap = HM.fromListWith (flip (<>)) [(k, [v]) | (k, v) <- frames]+      firstOf key = HM.lookup key tagMap >>= listToMaybe       -- Try to find and parse APIC frame for album art info (metadata only, not image data)       parsedAlbumArtInfo = findAndParseAPICInfo version (L.fromStrict tagData)   in metadata-    { title = HM.lookup "TIT2" tagMap <|> HM.lookup "TT2" tagMap-    , artist = HM.lookup "TPE1" tagMap <|> HM.lookup "TP1" tagMap-    , 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-    , genre = HM.lookup "TCON" tagMap <|> HM.lookup "TCO" tagMap-    , comment = HM.lookup "COMM" tagMap <|> HM.lookup "COM" tagMap <|> HM.lookup "TXXX:comment" tagMap-    , publisher = HM.lookup "TPUB" tagMap-    , recordLabel = HM.lookup "TXXX:LABEL" tagMap <|> HM.lookup "TPUB" tagMap-    , catalogNumber = HM.lookup "TXXX:CATALOGNUMBER" tagMap-    , barcode = HM.lookup "TXXX:BARCODE" tagMap-    , releaseCountry = HM.lookup "TXXX:MusicBrainz Album Release Country" tagMap-    , releaseStatus = HM.lookup "TXXX:MusicBrainz Album Status" tagMap-    , releaseType = HM.lookup "TXXX:MusicBrainz Album Type" tagMap+    { title = firstOf "TIT2" <|> firstOf "TT2"+    , artist = firstOf "TPE1" <|> firstOf "TP1"+    , album = firstOf "TALB" <|> firstOf "TAL"+    , albumArtist = firstOf "TPE2" <|> firstOf "TP2"+    , trackNumber = (firstOf "TRCK" <|> firstOf "TRK") >>= parseTrackNumber+    , totalTracks = (firstOf "TRCK" <|> firstOf "TRK") >>= parseTotal+    , discNumber = (firstOf "TPOS" <|> firstOf "TPA") >>= parseTrackNumber+    , totalDiscs = (firstOf "TPOS" <|> firstOf "TPA") >>= parseTotal+    , year = ((firstOf "TYER" <|> firstOf "TYE") >>= readInt)+             <|> (firstOf "TDRC" >>= extractYearFromDate)+    , date = firstOf "TDRC"+    , genre = resolveGenre <$> (firstOf "TCON" <|> firstOf "TCO")+    , comment = firstOf "COMM" <|> firstOf "COM" <|> firstOf "TXXX:comment"+    , publisher = firstOf "TPUB"+    , recordLabel = firstOf "TXXX:LABEL" <|> firstOf "TPUB"+    , catalogNumber = firstOf "TXXX:CATALOGNUMBER"+    , barcode = firstOf "TXXX:BARCODE"+    , releaseCountry = firstOf "TXXX:MusicBrainz Album Release Country"+    , releaseStatus = firstOf "TXXX:MusicBrainz Album Status"+    , releaseType = firstOf "TXXX:MusicBrainz Album Type"     , albumArtInfo = parsedAlbumArtInfo-    , musicBrainzIds = extractMusicBrainzIds tagMap-    , acoustidFingerprint = extractAcoustidFingerprint tagMap-    , acoustidId = extractAcoustidId tagMap+    , musicBrainzIds = extractMusicBrainzIds firstOf+    , acoustidFingerprint = extractAcoustidFingerprint firstOf+    , acoustidId = extractAcoustidId firstOf     , rawTags = tagMap  -- Populate rawTags with all parsed frames     }   where@@ -121,46 +146,107 @@     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-      , mbArtistId = HM.lookup "TXXX:MusicBrainz Artist Id" tags-      , mbAlbumArtistId = HM.lookup "TXXX:MusicBrainz Album Artist Id" tags-      , mbWorkId = HM.lookup "TXXX:MusicBrainz Work Id" tags-      , mbDiscId = HM.lookup "TXXX:MusicBrainz Disc Id" tags+    extractMusicBrainzIds firstOf = MusicBrainzIds+      { mbTrackId = firstOf "TXXX:MusicBrainz Release Track Id"+      -- Picard stores the recording id in UFID:http://musicbrainz.org+      , mbRecordingId = firstOf "UFID:http://musicbrainz.org"+                        <|> firstOf "TXXX:MusicBrainz Recording Id"+      , mbReleaseId = firstOf "TXXX:MusicBrainz Album Id"+      , mbReleaseGroupId = firstOf "TXXX:MusicBrainz Release Group Id"+      , mbArtistId = firstOf "TXXX:MusicBrainz Artist Id"+      , mbAlbumArtistId = firstOf "TXXX:MusicBrainz Album Artist Id"+      , mbWorkId = firstOf "TXXX:MusicBrainz Work Id"+      , mbDiscId = firstOf "TXXX:MusicBrainz Disc Id"       }-    extractAcoustidFingerprint tags = -      HM.lookup "TXXX:Acoustid Fingerprint" tags <|>-      HM.lookup "TXXX:ACOUSTID_FINGERPRINT" tags <|>-      HM.lookup "TXXX:acoustid_fingerprint" tags-    extractAcoustidId tags =-      HM.lookup "TXXX:Acoustid Id" tags <|>-      HM.lookup "TXXX:ACOUSTID_ID" tags <|>-      HM.lookup "TXXX:acoustid_id" tags+    extractAcoustidFingerprint firstOf =+      firstOf "TXXX:Acoustid Fingerprint" <|>+      firstOf "TXXX:ACOUSTID_FINGERPRINT" <|>+      firstOf "TXXX:acoustid_fingerprint"+    extractAcoustidId firstOf =+      firstOf "TXXX:Acoustid Id" <|>+      firstOf "TXXX:ACOUSTID_ID" <|>+      firstOf "TXXX:acoustid_id" --- | Parse ID3v2 frames-parseID3v2Frames :: Word8 -> L.ByteString -> [(Text, Text)]-parseID3v2Frames version bs-  | version == 2 = parseID3v22Frames bs  -- 3-char frame IDs-  | version >= 3 = parseID3v23Frames version bs  -- 4-char frame IDs-  | otherwise = []+-- | Extract raw frames (id, decoded content) from a complete ID3v2.3/2.4+-- tag payload, honouring tag-level unsynchronisation, the extended header+-- and v2.4 per-frame format flags. Exposed so the writer can carry binary+-- frames (USLT, APIC, PRIV, GEOB, UFID, ...) through an update verbatim.+extractRawFrames :: Word8 -> Word8 -> BS.ByteString -> [(BS.ByteString, BS.ByteString)]+extractRawFrames version flags rawTagData+  | version < 3 = []  -- v2.2 frames cannot be carried into a v2.4 tag+  | otherwise =+      let unsynced = if flags .&. 0x80 /= 0 then removeUnsync rawTagData else rawTagData+          tagData = if flags .&. 0x40 /= 0 then skipExtendedHeader version unsynced else unsynced+      in extractRawFramesFromPayload version tagData +-- | Like extractRawFrames, but for a payload whose tag-level+-- unsynchronisation and extended header are already dealt with+extractRawFramesFromPayload :: Word8 -> BS.ByteString -> [(BS.ByteString, BS.ByteString)]+extractRawFramesFromPayload version payload = go (L.fromStrict payload)+  where+    go bs+      | L.length bs < 10 = []+      | otherwise =+          case runGetOrFail rawFrame bs of+            Left _ -> []+            Right (rest, _, frame) -> frame : go rest++    rawFrame = do+      frameId <- getByteString 4+      -- Check for padding+      if BS.all (== 0) frameId+        then fail "Padding reached"+        else do+          -- Frame size (synchsafe for v2.4, normal for v2.3)+          frameSize <- if version >= 4+            then do+              b1 <- getWord8+              b2 <- getWord8+              b3 <- getWord8+              b4 <- getWord8+              return $ (fromIntegral b1 `shiftL` 21) .|.+                       (fromIntegral b2 `shiftL` 14) .|.+                       (fromIntegral b3 `shiftL` 7) .|.+                       (fromIntegral b4 :: Word32)+            else getWord32be++          frameFlags <- getWord16be+          rawData <- getByteString (fromIntegral frameSize)++          -- v2.4 format flags: 0x01 = data length indicator prepended (4+          -- bytes), 0x02 = frame content is unsynchronised+          let content+                | version >= 4 =+                    let afterDli = if frameFlags .&. 0x01 /= 0 then BS.drop 4 rawData else rawData+                    in if frameFlags .&. 0x02 /= 0 then removeUnsync afterDli else afterDli+                | otherwise = rawData+          return (frameId, content)++-- | Turn a raw frame into tag-map entries+classifyFrame :: (BS.ByteString, BS.ByteString) -> [(Text, Text)]+classifyFrame (frameId, frameData)+  | frameId == "APIC" = []  -- picture frames are handled separately+  | frameId == "COMM" = [(frameIdText, parseCOMMFrame frameData)]+  | frameId == "TXXX" =+      let (finalId, values) = parseTXXXFrame frameData+      in [(finalId, v) | v <- values]+  | frameId == "USLT" = [(frameIdText, parseUSLTFrame frameData)]+  | frameId == "UFID" = [parseUFIDFrame frameData]+  | otherwise = [(frameIdText, v) | v <- parseFrameContent frameData]+  where+    frameIdText = TE.decodeUtf8With TEE.lenientDecode frameId+ -- | Parse ID3v2.2 frames (3-character IDs) parseID3v22Frames :: L.ByteString -> [(Text, Text)] parseID3v22Frames bs   | L.length bs < 6 = []-  | otherwise = +  | otherwise =       case runGetOrFail parseID3v22Frame bs of         Left _ -> []-        Right (rest, _, Nothing) ->-          parseID3v22Frames rest  -- Skip and continue-        Right (rest, _, Just frame) ->-          frame : parseID3v22Frames rest+        Right (rest, _, pairs) ->+          pairs ++ parseID3v22Frames rest -parseID3v22Frame :: Get (Maybe (Text, Text))+parseID3v22Frame :: Get [(Text, Text)] parseID3v22Frame = do   frameId <- getByteString 3   -- Check for padding@@ -174,207 +260,160 @@       let frameSize = ((fromIntegral sizeByte1 :: Word32) `shiftL` 16) .|.                       ((fromIntegral sizeByte2 :: Word32) `shiftL` 8) .|.                       (fromIntegral sizeByte3 :: Word32)-      +       frameData <- getByteString (fromIntegral frameSize)       -- Skip PIC frames (ID3v2.2 version of APIC)       if frameId == "PIC"-        then return Nothing+        then return []         else do           let frameIdText = TE.decodeUtf8With TEE.lenientDecode frameId-          let frameValue = -                if frameId == "COM"-                then parseCOMMFrame frameData-                else if frameId == "TXX"-                then snd $ parseTXXXFrame frameData  -- v2.2 doesn't have description prefix-                else if frameId == "ULT"-                then parseUSLTFrame frameData-                else parseFrameContent frameData-          return $ Just (frameIdText, frameValue)+          return $+            if frameId == "COM"+            then [(frameIdText, parseCOMMFrame frameData)]+            else if frameId == "TXX"+            then [(frameIdText, v) | v <- snd (parseTXXXFrame frameData)]  -- v2.2 doesn't have description prefix+            else if frameId == "ULT"+            then [(frameIdText, parseUSLTFrame frameData)]+            else [(frameIdText, v) | v <- parseFrameContent frameData] --- | Parse ID3v2.3+ frames (4-character IDs)-parseID3v23Frames :: Word8 -> L.ByteString -> [(Text, Text)]-parseID3v23Frames version bs-  | L.length bs < 10 = []+-- | Parse text frame content. ID3v2.4 text frames may carry several+-- null-separated values (and taggers write them in v2.3 files too), so+-- this returns every value rather than mashing them into one string+parseFrameContent :: BS.ByteString -> [Text]+parseFrameContent bs+  | BS.null bs = []   | otherwise =-      case runGetOrFail (parseID3v23Frame version) bs of-        Left _ -> []-        Right (rest, _, Nothing) ->-          -- Frame was skipped (e.g., APIC), continue with the rest-          parseID3v23Frames version rest-        Right (rest, _, Just frame) ->-          frame : parseID3v23Frames version rest--parseID3v23Frame :: Word8 -> Get (Maybe (Text, Text))-parseID3v23Frame version = do-  frameId <- getByteString 4-  -- Check for padding-  if BS.all (== 0) frameId-    then fail "Padding reached"-    else do-      -- Frame size (synchsafe for v2.4, normal for v2.3)-      frameSize <- if version >= 4-        then do-          b1 <- getWord8-          b2 <- getWord8-          b3 <- getWord8-          b4 <- getWord8-          return $ (fromIntegral b1 `shiftL` 21) .|.-                   (fromIntegral b2 `shiftL` 14) .|.-                   (fromIntegral b3 `shiftL` 7) .|.-                   fromIntegral b4-        else getWord32be-      -      _ <- getWord16be  -- frameFlags-      frameData <- getByteString (fromIntegral frameSize)-      -      -- Skip APIC frames in this text-only parser-      if frameId == "APIC"-        then return Nothing  -- Skip picture frames but continue parsing-        else do-          let frameIdText = TE.decodeUtf8With TEE.lenientDecode frameId-          let (finalId, frameValue) = -                if frameId == "COMM" || frameId == "COM"-                then (frameIdText, parseCOMMFrame frameData)-                else if frameId == "TXXX"-                then parseTXXXFrame frameData-                else if frameId == "USLT"  -- Add support for lyrics-                then (frameIdText, parseUSLTFrame frameData)-                else (frameIdText, parseFrameContent frameData)-          return $ Just (finalId, frameValue)+      filter (not . T.null) $ T.split (== '\0') $+        decodeID3Text (BS.head bs) (BS.tail bs) --- | Parse frame content (simplified - handles text frames)-parseFrameContent :: BS.ByteString -> Text-parseFrameContent bs-  | BS.null bs = ""-  | otherwise = -      let encoding = BS.head bs-          content = BS.tail bs-      in T.filter (/= '\0') $ case encoding of  -- Strip null terminators after decoding-        0 -> -- ISO-8859-1: treat as Latin-1-          TE.decodeLatin1 content-        1 -> -- UTF-16 with BOM-          decodeUtf16 content-        2 -> -- UTF-16BE without BOM-          TE.decodeUtf16BEWith TEE.lenientDecode content-        3 -> -- UTF-8-          TE.decodeUtf8With TEE.lenientDecode content-        _ -> -- Unknown, try UTF-8-          TE.decodeUtf8With TEE.lenientDecode content+-- | Split at the text terminator for the given ID3 encoding: a 2-byte+-- aligned double null for the UTF-16 encodings, a single null otherwise.+-- Alignment matters: an unaligned search matches the null pair straddling+-- a UTF-16 code unit boundary (e.g. LE "A" = 41 00 followed by 00 00) and+-- shifts every following code unit by one byte.+-- Returns (before terminator, after terminator); with no terminator the+-- whole input is "before" and "after" is empty+splitAtTerminator :: Word8 -> BS.ByteString -> (BS.ByteString, BS.ByteString)+splitAtTerminator encoding bs+  | encoding == 1 || encoding == 2 = go 0+  | otherwise =+      let (before, after) = BS.break (== 0) bs+      in (before, BS.drop 1 after)   where-    decodeUtf16 bytes = -      -- Check for BOM and decode accordingly-      if BS.length bytes >= 2-        then case (BS.index bytes 0, BS.index bytes 1) of-          (0xFF, 0xFE) -> TE.decodeUtf16LEWith TEE.lenientDecode (BS.drop 2 bytes)-          (0xFE, 0xFF) -> TE.decodeUtf16BEWith TEE.lenientDecode (BS.drop 2 bytes)-          _ -> TE.decodeUtf16LEWith TEE.lenientDecode bytes-        else ""-    _decodeUtf16BE = TE.decodeUtf16BEWith TEE.lenientDecode+    go i+      | i + 1 >= BS.length bs = (bs, BS.empty)+      | BS.index bs i == 0 && BS.index bs (i + 1) == 0 = (BS.take i bs, BS.drop (i + 2) bs)+      | otherwise = go (i + 2) +-- | Decode text for the given ID3 encoding byte+decodeID3Text :: Word8 -> BS.ByteString -> Text+decodeID3Text 0 bytes = TE.decodeLatin1 bytes+decodeID3Text 1 bytes  -- UTF-16 with BOM+  | BS.length bytes >= 2 = case (BS.index bytes 0, BS.index bytes 1) of+      (0xFF, 0xFE) -> TE.decodeUtf16LEWith TEE.lenientDecode (BS.drop 2 bytes)+      (0xFE, 0xFF) -> TE.decodeUtf16BEWith TEE.lenientDecode (BS.drop 2 bytes)+      _ -> TE.decodeUtf16LEWith TEE.lenientDecode bytes+  | otherwise = ""+decodeID3Text 2 bytes = TE.decodeUtf16BEWith TEE.lenientDecode bytes+decodeID3Text _ bytes = TE.decodeUtf8With TEE.lenientDecode bytes+ -- | Parse COMM (comment) frame which has special structure parseCOMMFrame :: BS.ByteString -> Text parseCOMMFrame bs   | BS.length bs < 5 = ""  -- Need at least encoding + language (3) + content-  | otherwise = +  | otherwise =       let encoding = BS.head bs           rest = BS.drop 4 bs  -- Skip encoding + 3-byte language code-          -- Find the null terminator after the short description-          (_description, afterDesc) = case encoding of-            1 -> BS.breakSubstring "\0\0" rest  -- UTF-16 uses double null-            2 -> BS.breakSubstring "\0\0" rest  -- UTF-16BE uses double null-            _ -> BS.breakSubstring "\0" rest     -- ISO-8859-1 and UTF-8 use single null-          -- Skip the description and null terminator(s)-          content = case encoding of-            1 -> if BS.null afterDesc then BS.empty else BS.drop 2 afterDesc  -- Skip \0\0-            2 -> if BS.null afterDesc then BS.empty else BS.drop 2 afterDesc  -- Skip \0\0-            _ -> if BS.null afterDesc then BS.empty else BS.drop 1 afterDesc  -- Skip \0-          -- Decode the actual comment text-      in case encoding of-        0 -> TE.decodeLatin1 content  -- ISO-8859-1 (Latin-1)-        1 -> decodeUtf16 content  -- UTF-16 with BOM-        2 -> TE.decodeUtf16BEWith TEE.lenientDecode content  -- UTF-16BE-        3 -> TE.decodeUtf8With TEE.lenientDecode content  -- UTF-8-        _ -> TE.decodeUtf8With TEE.lenientDecode content-  where-    decodeUtf16 content = -      if BS.length content >= 2-        then case (BS.index content 0, BS.index content 1) of-          (0xFF, 0xFE) -> TE.decodeUtf16LEWith TEE.lenientDecode (BS.drop 2 content)-          (0xFE, 0xFF) -> TE.decodeUtf16BEWith TEE.lenientDecode (BS.drop 2 content)-          _ -> TE.decodeUtf16LEWith TEE.lenientDecode content-        else ""+          (_description, content) = splitAtTerminator encoding rest+      in decodeID3Text encoding content  -- | Parse TXXX frame (user-defined text information frame)--- Returns (frameId with description, value)-parseTXXXFrame :: BS.ByteString -> (Text, Text)+-- Returns (frameId with description, values); the value part may hold+-- several null-separated values like any other text frame+parseTXXXFrame :: BS.ByteString -> (Text, [Text]) parseTXXXFrame bs-  | BS.null bs = ("TXXX", "")-  | otherwise = +  | BS.null bs = ("TXXX", [])+  | otherwise =       let encoding = BS.head bs           rest = BS.tail bs-          -- Find the null terminator after the description-          (descBytes, afterDesc) = case encoding of-            1 -> BS.breakSubstring "\0\0" rest  -- UTF-16 uses double null-            2 -> BS.breakSubstring "\0\0" rest  -- UTF-16BE uses double null-            _ -> BS.breakSubstring "\0" rest     -- ISO-8859-1 and UTF-8 use single null-          -- Skip the description and null terminator(s)-          valueBytes = case encoding of-            1 -> if BS.null afterDesc then BS.empty else BS.drop 2 afterDesc  -- Skip \0\0-            2 -> if BS.null afterDesc then BS.empty else BS.drop 2 afterDesc  -- Skip \0\0-            _ -> if BS.null afterDesc then BS.empty else BS.drop 1 afterDesc  -- Skip \0-          -- Decode both description and value-          description = T.filter (/= '\0') $ decodeByEncoding encoding descBytes-          value = T.filter (/= '\0') $ decodeByEncoding encoding valueBytes+          (descBytes, valueBytes) = splitAtTerminator encoding rest+          description = T.filter (/= '\0') $ decodeID3Text encoding descBytes+          values = filter (not . T.null) $ T.split (== '\0') $+            decodeID3Text encoding valueBytes           frameId = if T.null description then "TXXX" else "TXXX:" <> description-      in (frameId, value)-  where-    decodeByEncoding 0 bytes = TE.decodeLatin1 bytes  -- ISO-8859-1-    decodeByEncoding 1 bytes = decodeUtf16 bytes  -- UTF-16 with BOM-    decodeByEncoding 2 bytes = TE.decodeUtf16BEWith TEE.lenientDecode bytes  -- UTF-16BE-    decodeByEncoding 3 bytes = TE.decodeUtf8With TEE.lenientDecode bytes  -- UTF-8-    decodeByEncoding _ bytes = TE.decodeUtf8With TEE.lenientDecode bytes-    -    decodeUtf16 bytes = -      if BS.length bytes >= 2-        then case (BS.index bytes 0, BS.index bytes 1) of-          (0xFF, 0xFE) -> TE.decodeUtf16LEWith TEE.lenientDecode (BS.drop 2 bytes)-          (0xFE, 0xFF) -> TE.decodeUtf16BEWith TEE.lenientDecode (BS.drop 2 bytes)-          _ -> TE.decodeUtf16LEWith TEE.lenientDecode bytes-        else ""+      in (frameId, values) +-- | The ID3v1 genre list (0-79) plus the Winamp extensions (80-147)+id3v1Genres :: [Text]+id3v1Genres =+  [ "Blues", "Classic Rock", "Country", "Dance", "Disco", "Funk", "Grunge"+  , "Hip-Hop", "Jazz", "Metal", "New Age", "Oldies", "Other", "Pop", "R&B"+  , "Rap", "Reggae", "Rock", "Techno", "Industrial", "Alternative", "Ska"+  , "Death Metal", "Pranks", "Soundtrack", "Euro-Techno", "Ambient"+  , "Trip-Hop", "Vocal", "Jazz+Funk", "Fusion", "Trance", "Classical"+  , "Instrumental", "Acid", "House", "Game", "Sound Clip", "Gospel", "Noise"+  , "AlternRock", "Bass", "Soul", "Punk", "Space", "Meditative"+  , "Instrumental Pop", "Instrumental Rock", "Ethnic", "Gothic", "Darkwave"+  , "Techno-Industrial", "Electronic", "Pop-Folk", "Eurodance", "Dream"+  , "Southern Rock", "Comedy", "Cult", "Gangsta", "Top 40", "Christian Rap"+  , "Pop/Funk", "Jungle", "Native American", "Cabaret", "New Wave"+  , "Psychadelic", "Rave", "Showtunes", "Trailer", "Lo-Fi", "Tribal"+  , "Acid Punk", "Acid Jazz", "Polka", "Retro", "Musical", "Rock & Roll"+  , "Hard Rock", "Folk", "Folk-Rock", "National Folk", "Swing", "Fast Fusion"+  , "Bebob", "Latin", "Revival", "Celtic", "Bluegrass", "Avantgarde"+  , "Gothic Rock", "Progressive Rock", "Psychedelic Rock", "Symphonic Rock"+  , "Slow Rock", "Big Band", "Chorus", "Easy Listening", "Acoustic", "Humour"+  , "Speech", "Chanson", "Opera", "Chamber Music", "Sonata", "Symphony"+  , "Booty Bass", "Primus", "Porn Groove", "Satire", "Slow Jam", "Club"+  , "Tango", "Samba", "Folklore", "Ballad", "Power Ballad", "Rhythmic Soul"+  , "Freestyle", "Duet", "Punk Rock", "Drum Solo", "A Cappella", "Euro-House"+  , "Dance Hall", "Goa", "Drum & Bass", "Club-House", "Hardcore", "Terror"+  , "Indie", "BritPop", "Negerpunk", "Polsk Punk", "Beat"+  , "Christian Gangsta Rap", "Heavy Metal", "Black Metal", "Crossover"+  , "Contemporary Christian", "Christian Rock", "Merengue", "Salsa"+  , "Thrash Metal", "Anime", "Jpop", "Synthpop"+  ]++genreByIndex :: Int -> Maybe Text+genreByIndex i+  | i >= 0 && i < length id3v1Genres = Just (id3v1Genres !! i)+  | otherwise = Nothing++-- | Resolve numeric genre references: ID3v2.3 "(17)" (optionally followed+-- by a textual refinement, which wins) and ID3v2.4 bare numeric strings+resolveGenre :: Text -> Text+resolveGenre t+  | Just rest <- T.stripPrefix "(" t+  , (digits, closeAndAfter) <- T.span isDigit rest+  , Just after <- T.stripPrefix ")" closeAndAfter+  , not (T.null digits)+  = if T.null after+      then fromMaybe t (readInt digits >>= genreByIndex)+      else after+  | not (T.null t), T.all isDigit t+  = fromMaybe t (readInt t >>= genreByIndex)+  | otherwise = t++-- | Parse UFID frame (unique file identifier): a null-terminated Latin-1+-- owner URL followed by the identifier. MusicBrainz identifiers are ASCII+-- UUIDs, so the identifier is decoded as text.+parseUFIDFrame :: BS.ByteString -> (Text, Text)+parseUFIDFrame bs =+  let (owner, rest) = BS.break (== 0) bs+      identifier = BS.drop 1 rest+  in ( "UFID:" <> TE.decodeLatin1 owner+     , T.filter (/= '\0') $ TE.decodeUtf8With TEE.lenientDecode identifier+     )+ -- | Parse USLT frame (unsynchronized lyrics/text transcription) parseUSLTFrame :: BS.ByteString -> Text parseUSLTFrame bs   | BS.length bs < 5 = ""  -- Need at least encoding + language (3) + content-  | otherwise = +  | otherwise =       let encoding = BS.head bs           rest = BS.drop 4 bs  -- Skip encoding + 3-byte language code-          -- Find the null terminator after the content descriptor-          (_, afterDesc) = case encoding of-            1 -> BS.breakSubstring "\0\0" rest  -- UTF-16 uses double null-            2 -> BS.breakSubstring "\0\0" rest  -- UTF-16BE uses double null-            _ -> BS.breakSubstring "\0" rest     -- ISO-8859-1 and UTF-8 use single null-          -- Skip the descriptor and null terminator(s)-          lyricsBytes = case encoding of-            1 -> if BS.null afterDesc then BS.empty else BS.drop 2 afterDesc  -- Skip \0\0-            2 -> if BS.null afterDesc then BS.empty else BS.drop 2 afterDesc  -- Skip \0\0-            _ -> if BS.null afterDesc then BS.empty else BS.drop 1 afterDesc  -- Skip \0-          -- Decode lyrics-      in T.filter (/= '\0') $ decodeByEncoding encoding lyricsBytes-  where-    decodeByEncoding 0 bytes = TE.decodeLatin1 bytes-    decodeByEncoding 1 bytes = decodeUtf16 bytes -    decodeByEncoding 2 bytes = TE.decodeUtf16BEWith TEE.lenientDecode bytes-    decodeByEncoding 3 bytes = TE.decodeUtf8With TEE.lenientDecode bytes-    decodeByEncoding _ bytes = TE.decodeUtf8With TEE.lenientDecode bytes-    -    decodeUtf16 bytes = -      if BS.length bytes >= 2-        then case (BS.index bytes 0, BS.index bytes 1) of-          (0xFF, 0xFE) -> TE.decodeUtf16LEWith TEE.lenientDecode (BS.drop 2 bytes)-          (0xFE, 0xFF) -> TE.decodeUtf16BEWith TEE.lenientDecode (BS.drop 2 bytes)-          _ -> TE.decodeUtf16LEWith TEE.lenientDecode bytes-        else ""+          (_descriptor, lyricsBytes) = splitAtTerminator encoding rest+      in T.filter (/= '\0') $ decodeID3Text encoding lyricsBytes  -- | Parse ID3v1 tag from file handle if present parseID3v1FromHandle :: Handle -> Metadata -> IO Metadata@@ -396,19 +435,26 @@   , artist = artist metadata <|> parseID3v1Field bs 33 30   , album = album metadata <|> parseID3v1Field bs 63 30   , year = year metadata <|> (parseID3v1Field bs 93 4 >>= readInt)-  , comment = comment metadata <|> parseID3v1Field bs 97 28+  , comment = comment metadata <|> parseID3v1Field bs 97 commentLength+  , genre = genre metadata <|> genreByIndex (fromIntegral $ BS.index bs 127)   , trackNumber = trackNumber metadata <|>-      if BS.index bs 125 == 0 && BS.index bs 126 /= 0+      if hasTrackNumber       then Just (fromIntegral $ BS.index bs 126)       else Nothing   }   where+    -- ID3v1.1 shortens the comment to 28 bytes to fit a track number,+    -- marked by a null at byte 125; plain v1.0 comments are 30 bytes+    hasTrackNumber = BS.index bs 125 == 0 && BS.index bs 126 /= 0+    commentLength = if hasTrackNumber then 28 else 30+     parseID3v1Field bytes offset len =       let field = BS.take len (BS.drop offset bytes)           cleaned = BS.takeWhile (/= 0) field+      -- ID3v1 predates Unicode: fields are Latin-1, not UTF-8       in if BS.null cleaned          then Nothing-         else Just $ TE.decodeUtf8With TEE.lenientDecode cleaned+         else Just $ TE.decodeLatin1 cleaned  -- | Parse MP3 audio properties from file handle parseMP3AudioPropertiesFromHandle :: Handle -> IO AudioProperties@@ -455,7 +501,9 @@     then return 0     else do       let size = parseSynchsafeInt (BS.drop 6 header)-      return $ 10 + fromIntegral size+          -- The v2.4 footer flag adds 10 bytes after the tag data+          footerSize = if BS.index header 5 .&. 0x10 /= 0 then 10 else 0 :: Integer+      return $ 10 + fromIntegral size + footerSize  -- | Find MP3 frame sync findMP3FrameSync :: Handle -> Int -> IO (Maybe BS.ByteString)@@ -471,8 +519,17 @@               Just pos -> do                 hSeek handle RelativeSeek (fromIntegral pos - fromIntegral (BS.length chunk))                 header <- BS.hGet handle 4-                return $ Just header-              Nothing -> searchSync (bytesRead' + BS.length chunk)+                -- A sync pattern right at EOF yields a short header, which+                -- parseMP3FrameHeader cannot index into+                return $ if BS.length header == 4 then Just header else Nothing+              Nothing+                -- A sync pattern can straddle the chunk boundary (0xFF as+                -- the last byte of one chunk); step back one byte so it+                -- pairs with the next chunk+                | BS.length chunk > 1 -> do+                    hSeek handle RelativeSeek (-1)+                    searchSync (bytesRead' + BS.length chunk - 1)+                | otherwise -> searchSync (bytesRead' + BS.length chunk)          findSync bs =        let indices = [i | i <- [0..BS.length bs - 2]@@ -550,9 +607,17 @@   if BS.length frameData < 40     then return props     else do-      -- Check for Xing/Info header (usually at offset 36 for stereo, 21 for mono)-      let numChannels = fromMaybe 2 (channels props)-          xingOffset = if numChannels == 1 then 21 else 36+      -- The Xing/Info header sits after the side info, whose size depends+      -- on MPEG version and channel mode: MPEG1 32/17 bytes (stereo/mono),+      -- MPEG2/2.5 17/9 bytes, plus the 4-byte frame header+      let versionBits = (BS.index frameData 1 `shiftR` 3) .&. 0x03+          isMpeg1 = versionBits == 3+          numChannels = fromMaybe 2 (channels props)+          xingOffset = case (isMpeg1, numChannels == 1) of+            (True, True) -> 21+            (True, False) -> 36+            (False, True) -> 13+            (False, False) -> 21              if BS.length frameData > xingOffset + 12         then do@@ -576,17 +641,23 @@   if BS.length bs < 8     then return props     else do-      let flags = runGet getWord32be (L.fromStrict $ BS.take 4 bs)+      -- Only read fields the buffer actually holds; the length guard above+      -- covers the flags but not both optional counters+      let word32At off+            | BS.length bs >= off + 4 =+                Just $ runGet getWord32be (L.fromStrict $ BS.take 4 $ BS.drop off bs)+            | otherwise = Nothing+          flags = fromMaybe 0 (word32At 0)           hasFrames = (flags .&. 0x01) /= 0           hasBytes = (flags .&. 0x02) /= 0-          +       -- Parse frame count and byte count if present       let offset1 = 4           (frameCount, offset2) = if hasFrames-            then (Just $ runGet getWord32be (L.fromStrict $ BS.take 4 $ BS.drop offset1 bs), offset1 + 4)+            then (word32At offset1, offset1 + 4)             else (Nothing, offset1)           (byteCount, _) = if hasBytes-            then (Just $ runGet getWord32be (L.fromStrict $ BS.take 4 $ BS.drop offset2 bs), offset2 + 4)+            then (word32At offset2, offset2 + 4)             else (Nothing, offset2)              -- Calculate average bitrate and duration for VBR

@@ -20,7 +20,7 @@ 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.Maybe (catMaybes, fromMaybe, listToMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE@@ -30,6 +30,7 @@ import System.File.OsPath (withBinaryFile)  import Monatone.Metadata+import Monatone.MP3 (extractRawFrames)  -- Re-define WriteError and Writer locally to avoid circular imports data WriteError@@ -46,12 +47,11 @@ bufferSize = 65536  -- | Write metadata to MP3 file incrementally without loading the entire file--- Takes optional AlbumArt separately since Metadata only stores AlbumArtInfo-writeMP3Metadata :: Metadata -> Maybe AlbumArt -> OsPath -> Writer ()-writeMP3Metadata metadata maybeAlbumArt filePath = do+writeMP3Metadata :: Metadata -> AlbumArtUpdate -> OsPath -> Writer ()+writeMP3Metadata metadata artUpdate filePath = do   -- Open file in read/write mode   result <- liftIO $ tryIO $ withBinaryFile filePath ReadWriteMode $ \handle -> do-    runExceptT $ writeMP3HandleIncremental metadata maybeAlbumArt handle+    runExceptT $ writeMP3HandleIncremental metadata artUpdate handle   case result of     Left (e :: IOException) -> throwError $ WriteIOError $ T.pack $ show e     Right (Left err) -> throwError err@@ -61,13 +61,17 @@     tryIO action = catch (Right <$> action) (return . Left)  -- | Write MP3 metadata using a file handle incrementally-writeMP3HandleIncremental :: Metadata -> Maybe AlbumArt -> Handle -> Writer ()-writeMP3HandleIncremental metadata maybeAlbumArt handle = do+writeMP3HandleIncremental :: Metadata -> AlbumArtUpdate -> Handle -> Writer ()+writeMP3HandleIncremental metadata artUpdate handle = do   -- Find where the audio data starts (after existing ID3v2 tag if present)   audioDataOffset <- findAudioDataOffsetHandle handle +  -- Frames that cannot be regenerated from text (APIC, USLT, PRIV, GEOB,+  -- foreign UFIDs, ...) are carried over from the existing tag verbatim+  existingRawFrames <- liftIO $ readExistingRawFrames handle+   -- Generate new ID3v2 tag-  newTagData <- generateID3v2Tag metadata maybeAlbumArt+  newTagData <- generateID3v2Tag metadata artUpdate existingRawFrames   let newTagSize = fromIntegral $ L.length newTagData      -- Get file size@@ -98,6 +102,47 @@     -- Then delete the extra space     deleteBytesInFile handle bytesToDelete newTagSize +  -- Refresh any existing ID3v1 tag: it would otherwise keep showing the+  -- pre-update fields to v1-only readers+  liftIO $ refreshID3v1 metadata handle++-- | Rewrite an existing ID3v1 tag at the end of the file from the current+-- metadata; files without a v1 tag are left alone+refreshID3v1 :: Metadata -> Handle -> IO ()+refreshID3v1 metadata handle = do+  fileSize <- hFileSize handle+  if fileSize <= 128+    then return ()+    else do+      hSeek handle AbsoluteSeek (fileSize - 128)+      existing <- BS.hGet handle 3+      if existing /= "TAG"+        then return ()+        else do+          hSeek handle AbsoluteSeek (fileSize - 128)+          BS.hPut handle (generateID3v1Tag metadata)++-- | Render a 128-byte ID3v1 tag (v1.1 when a track number is present)+generateID3v1Tag :: Metadata -> BS.ByteString+generateID3v1Tag metadata = BS.concat+  [ "TAG"+  , field 30 (title metadata)+  , field 30 (artist metadata)+  , field 30 (album metadata)+  , field 4 (T.pack . show <$> year metadata)+  , commentAndTrack+  , BS.singleton 0xFF  -- genre: none (no reliable text-to-index mapping)+  ]+  where+    field n maybeText =+      BS.take n $ toLatin1 (fromMaybe "" maybeText) <> BS.replicate n 0+    -- ID3v1 is Latin-1; characters outside it become '?'+    toLatin1 = BS.pack . map (\c -> if fromEnum c < 256 then fromIntegral (fromEnum c) else 0x3F) . T.unpack+    commentAndTrack = case trackNumber metadata of+      Just n | n > 0 && n < 256 ->+        field 28 (comment metadata) <> BS.pack [0, fromIntegral n]+      _ -> field 30 (comment metadata)+ -- | Find the start of audio data by skipping existing ID3v2 tag using a handle findAudioDataOffsetHandle :: Handle -> Writer Int findAudioDataOffsetHandle handle = do@@ -115,9 +160,13 @@         -- Parse the ID3v2 header to get tag size         case BS.unpack (BS.drop 6 headerBytes) of           [s1, s2, s3, s4] -> do-            -- ID3v2 size is stored as a syncsafe integer (28 bits)+            -- ID3v2 size is stored as a syncsafe integer (28 bits); a tag+            -- with the footer flag has 10 more bytes after the tag data,+            -- which must be replaced too or they would linger before the+            -- audio             let tagSize = syncSafeToInt s1 s2 s3 s4-            return $ 10 + tagSize  -- Header (10 bytes) + tag data+                footerSize = if BS.index headerBytes 5 .&. 0x10 /= 0 then 10 else 0+            return $ 10 + tagSize + footerSize           _ -> throwError $ CorruptedWrite "Invalid ID3v2 header"       _ -> return 0  -- No ID3v2 tag, audio data starts at beginning @@ -207,17 +256,41 @@       b4 = fromIntegral $ n .&. 0x7F   in (b1, b2, b3, b4) +-- | Like intToSyncSafe, but rejects sizes beyond the 28-bit syncsafe range+-- instead of silently truncating them into a corrupt tag+syncSafeOrFail :: Int -> Writer (Word8, Word8, Word8, Word8)+syncSafeOrFail n+  | n < 0 || n >= 0x10000000 =+      throwError $ InvalidMetadata "Content exceeds ID3v2's 256MiB syncsafe size limit"+  | otherwise = return $ intToSyncSafe n++-- | Read raw frames from an existing ID3v2.3/2.4 tag at the start of the+-- file (empty when there is none)+readExistingRawFrames :: Handle -> IO [(ByteString, ByteString)]+readExistingRawFrames handle = do+  hSeek handle AbsoluteSeek 0+  header <- BS.hGet handle 10+  if BS.length header < 10 || BS.take 3 header /= "ID3"+    then return []+    else do+      let version = BS.index header 3+          flags = BS.index header 5+          [s1, s2, s3, s4] = BS.unpack $ BS.take 4 $ BS.drop 6 header+          tagSize = syncSafeToInt s1 s2 s3 s4+      tagData <- BS.hGet handle tagSize+      return $ extractRawFrames version flags tagData+ -- | Generate complete ID3v2.4 tag-generateID3v2Tag :: Metadata -> Maybe AlbumArt -> Writer L.ByteString-generateID3v2Tag metadata maybeAlbumArt = do+generateID3v2Tag :: Metadata -> AlbumArtUpdate -> [(ByteString, ByteString)] -> Writer L.ByteString+generateID3v2Tag metadata artUpdate existingRawFrames = do   -- Generate all frames-  frames <- generateFrames metadata maybeAlbumArt+  frames <- generateFrames metadata artUpdate existingRawFrames   let framesData = L.concat frames       framesSize = fromIntegral $ L.length framesData      -- Create ID3v2.4 header-  let (s1, s2, s3, s4) = intToSyncSafe framesSize-      header = runPut $ do+  (s1, s2, s3, s4) <- syncSafeOrFail framesSize+  let header = runPut $ do         putByteString "ID3"      -- Signature         putWord8 4               -- Major version (2.4)         putWord8 0               -- Revision version@@ -230,62 +303,102 @@   return $ header <> framesData  -- | 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+-- parser maps is written back; unmapped text frames in rawTags and+-- unmapped binary frames from the existing tag are carried over so an+-- update never drops tags it does not understand.+generateFrames :: Metadata -> AlbumArtUpdate -> [(ByteString, ByteString)] -> Writer [L.ByteString]+generateFrames metadata artUpdate existingRawFrames = do   mapped <- sequence $     [ generateTextFrame frameId value | (frameId, value) <- textFrames ] ++     [ generateTXXXFrame description value | (description, value) <- txxxFrames ] +  -- Picard convention: the recording id lives in UFID:http://musicbrainz.org+  ufidFrames <- case mbRecordingId mbIds of+    Nothing -> return []+    Just recordingId ->+      (: []) <$> generateUFIDFrame "http://musicbrainz.org" recordingId+   commFrames <- case comment metadata of     Nothing -> return []     Just c -> (: []) <$> generateCOMMFrame c    preserved <- generatePreservedFrames metadata -  apicFrames <- case maybeAlbumArt of-    Nothing -> return []-    Just art -> (: []) <$> generateAPICFrame art+  -- Carry frames that cannot be regenerated from text (lyrics, private+  -- data, foreign identifiers, ...) over verbatim+  carried <- mapM (uncurry generateRawFrame)+    [ frame | frame@(frameId, content) <- existingRawFrames+    , isCarriedVerbatim frameId content+    ] -  return $ mapped ++ commFrames ++ preserved ++ apicFrames+  apicFrames <- case artUpdate of+    SetAlbumArt art -> (: []) <$> generateAPICFrame art+    KeepExistingArt ->+      -- Existing pictures pass through verbatim+      mapM (generateRawFrame "APIC")+        [ content | ("APIC", content) <- existingRawFrames ]+    RemoveAlbumArt -> return []++  return $ mapped ++ ufidFrames ++ commFrames ++ preserved ++ carried ++ apicFrames   where     mbIds = musicBrainzIds metadata     showT = T.pack . show +    -- Verbatim carry-over covers everything the tag map cannot represent:+    -- not text frames (regenerated from fields/rawTags), not COMM (the+    -- comment field owns it), not APIC (owned by the art instruction),+    -- and not the MusicBrainz UFID (regenerated from mbRecordingId)+    isCarriedVerbatim frameId content+      | BS.isPrefixOf "T" frameId = False+      | frameId `elem` ["COMM", "APIC"] = False+      | frameId == "UFID" = BS.takeWhile (/= 0) content /= "http://musicbrainz.org"+      | otherwise = True+     -- "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 +    -- A scalar field is the first value of a possibly multi-valued key.+    -- If the field still matches what was parsed, write every stored value+    -- back (null-separated, ID3v2.4 style); if it was edited, the edit+    -- replaces the whole set.+    multi key field = case field of+      Nothing -> Nothing+      Just v ->+        let stored = HM.lookupDefault [] key (rawTags metadata)+        in Just $ if listToMaybe stored == Just v then stored else [v]++    single field = (: []) <$> field+     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))+      [ ("TIT2",) <$> multi "TIT2" (title metadata)+      , ("TPE1",) <$> multi "TPE1" (artist metadata)+      , ("TALB",) <$> multi "TALB" (album metadata)+      , ("TPE2",) <$> multi "TPE2" (albumArtist metadata)+      , ("TCON",) <$> multi "TCON" (genre metadata)+      , ("TPUB",) <$> multi "TPUB" (publisher metadata)+      , ("TRCK",) <$> single (numWithTotal (trackNumber metadata) (totalTracks metadata))+      , ("TPOS",) <$> single (numWithTotal (discNumber metadata) (totalDiscs metadata))+      , ("TDRC",) <$> single (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+      [ ("BARCODE",) <$> single (barcode metadata)+      , ("CATALOGNUMBER",) <$> single (catalogNumber metadata)+      , ("LABEL",) <$> single (recordLabel metadata)+      , ("MusicBrainz Album Release Country",) <$> single (releaseCountry metadata)+      , ("MusicBrainz Album Status",) <$> single (releaseStatus metadata)+      , ("MusicBrainz Album Type",) <$> single (releaseType metadata)+      , ("MusicBrainz Release Track Id",) <$> single (mbTrackId mbIds)+      , ("MusicBrainz Album Id",) <$> single (mbReleaseId mbIds)+      , ("MusicBrainz Release Group Id",) <$> single (mbReleaseGroupId mbIds)+      -- Multiple credited artists mean multiple MusicBrainz artist ids+      , ("MusicBrainz Artist Id",) <$> multi "TXXX:MusicBrainz Artist Id" (mbArtistId mbIds)+      , ("MusicBrainz Album Artist Id",) <$> multi "TXXX:MusicBrainz Album Artist Id" (mbAlbumArtistId mbIds)+      , ("MusicBrainz Work Id",) <$> single (mbWorkId mbIds)+      , ("MusicBrainz Disc Id",) <$> single (mbDiscId mbIds)+      , ("Acoustid Fingerprint",) <$> single (acoustidFingerprint metadata)+      , ("Acoustid Id",) <$> single (acoustidId metadata)       ]  -- | Re-emit raw frames the mapped fields do not own. rawTags only holds@@ -294,19 +407,40 @@ generatePreservedFrames :: Metadata -> Writer [L.ByteString] generatePreservedFrames metadata = mapM emit preservable   where+    -- One frame per key: multi-valued keys become one null-separated+    -- frame, since duplicate frames of the same ID are invalid     preservable =-      [ kv | kv@(key, _) <- HM.toList (rawTags metadata), isPreservable key ]+      [ (key, values)+      | (key, values) <- HM.toList (rawTags metadata)+      , isPreservable key+      , not (null values)+      ]      isPreservable key       | Just description <- T.stripPrefix "TXXX:" key =           T.toLower description `notElem` handledDescriptions+      | T.length key == 3 = key `elem` map fst v22TextFrames       | 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+    emit (key, values) = case T.stripPrefix "TXXX:" key of+      Just description -> generateTXXXFrame description values+      Nothing -> case lookup key v22TextFrames of+        Just v24Id -> generateTextFrame v24Id values+        Nothing -> generateTextFrame (TE.encodeUtf8 key) values +    -- ID3v2.2 3-character text frame ids translated to their v2.4+    -- equivalents so unmapped v2.2 values survive an update. Ids whose+    -- values are carried by mapped fields (TT2, TP1, ...) are absent.+    v22TextFrames :: [(Text, ByteString)]+    v22TextFrames =+      [ ("TT1", "TIT1"), ("TT3", "TIT3"), ("TP3", "TPE3"), ("TP4", "TPE4")+      , ("TCM", "TCOM"), ("TXT", "TEXT"), ("TLA", "TLAN"), ("TLE", "TLEN")+      , ("TMT", "TMED"), ("TKE", "TKEY"), ("TBP", "TBPM"), ("TSS", "TSSE")+      , ("TEN", "TENC"), ("TCR", "TCOP"), ("TDY", "TDLY"), ("TOT", "TOAL")+      , ("TOA", "TOPE"), ("TOL", "TOLY"), ("TFT", "TFLT"), ("TRC", "TSRC")+      ]+     -- Frames the mapped fields own (whether or not they are set right now):     -- stale rawTags copies of these must not be written back     handledTextFrames =@@ -327,14 +461,15 @@       , "Acoustid Fingerprint", "Acoustid Id"       ] --- | Generate a text frame (TIT2, TPE1, TALB, etc.)-generateTextFrame :: ByteString -> Text -> Writer L.ByteString-generateTextFrame frameId text = do-  -- Encode text as UTF-8 with BOM-  let textBytes = BS.cons 0x03 $ TE.encodeUtf8 text  -- 0x03 = UTF-8 encoding+-- | Generate a text frame (TIT2, TPE1, TALB, etc.); several values are+-- encoded null-separated per ID3v2.4+generateTextFrame :: ByteString -> [Text] -> Writer L.ByteString+generateTextFrame frameId values = do+  let content = BS.intercalate "\0" (map TE.encodeUtf8 values)+      textBytes = BS.cons 0x03 content  -- 0x03 = UTF-8 encoding       frameSize = BS.length textBytes-      (s1, s2, s3, s4) = intToSyncSafe frameSize-      +  (s1, s2, s3, s4) <- syncSafeOrFail frameSize+   return $ runPut $ do     putByteString frameId       -- Frame ID (4 bytes)     putWord8 s1                 -- Frame size as syncsafe integer@@ -353,8 +488,8 @@              -- Calculate frame content size       frameSize = 1 + BS.length mimeBytes + 1 + 1 + BS.length descBytes + 1 + BS.length imageData-      (s1, s2, s3, s4) = intToSyncSafe frameSize-      +  (s1, s2, s3, s4) <- syncSafeOrFail frameSize+   return $ runPut $ do     putByteString "APIC"        -- Frame ID     putWord8 s1                 -- Frame size as syncsafe integer@@ -370,6 +505,28 @@     putWord8 0x00                           -- Null terminator       putByteString imageData                 -- Image data +-- | Generate a frame with pre-rendered content (used for UFID and for+-- frames carried over verbatim)+generateRawFrame :: ByteString -> ByteString -> Writer L.ByteString+generateRawFrame frameId frameContent = do+  (s1, s2, s3, s4) <- syncSafeOrFail (BS.length frameContent)+  return $ runPut $ do+    putByteString frameId+    putWord8 s1+    putWord8 s2+    putWord8 s3+    putWord8 s4+    putWord16be 0               -- Frame flags+    putByteString frameContent++-- | Generate UFID frame: null-terminated Latin-1 owner + identifier+generateUFIDFrame :: Text -> Text -> Writer L.ByteString+generateUFIDFrame owner identifier = generateRawFrame "UFID" $ BS.concat+  [ TE.encodeUtf8 owner     -- owner URLs are ASCII in practice+  , BS.singleton 0x00+  , TE.encodeUtf8 identifier+  ]+ -- | Generate COMM frame for comments (has special structure) generateCOMMFrame :: Text -> Writer L.ByteString generateCOMMFrame commentText = do@@ -382,7 +539,7 @@         textBytes                -- Actual comment text         ]       frameSize = BS.length frameContent-      (s1, s2, s3, s4) = intToSyncSafe frameSize+  (s1, s2, s3, s4) <- syncSafeOrFail frameSize    return $ runPut $ do     putByteString "COMM"        -- Frame ID@@ -393,20 +550,21 @@     putWord16be 0               -- Frame flags     putByteString frameContent  -- Frame content --- | Generate TXXX frame for user-defined text information-generateTXXXFrame :: Text -> Text -> Writer L.ByteString-generateTXXXFrame description text = do+-- | Generate TXXX frame for user-defined text information; several values+-- are encoded null-separated per ID3v2.4+generateTXXXFrame :: Text -> [Text] -> Writer L.ByteString+generateTXXXFrame description values = do   let descBytes = TE.encodeUtf8 description-      textBytes = TE.encodeUtf8 text-      -- TXXX structure: encoding + description + null + text value+      textBytes = BS.intercalate "\0" (map TE.encodeUtf8 values)+      -- TXXX structure: encoding + description + null + text value(s)       frameContent = BS.concat [         BS.singleton 0x03,       -- UTF-8 encoding         descBytes,               -- Description         BS.singleton 0x00,       -- Null terminator-        textBytes                -- Text value+        textBytes                -- Text value(s)         ]       frameSize = BS.length frameContent-      (s1, s2, s3, s4) = intToSyncSafe frameSize+  (s1, s2, s3, s4) <- syncSafeOrFail frameSize    return $ runPut $ do     putByteString "TXXX"        -- Frame ID

@@ -12,6 +12,7 @@   , MusicBrainzIds(..)   , AlbumArtInfo(..)   , AlbumArt(..)+  , AlbumArtUpdate(..)   , emptyMetadata   , emptyAudioProperties   , emptyMusicBrainzIds@@ -117,6 +118,14 @@   , albumArtData :: ByteString         -- Binary image data   } deriving (Show, Eq) +-- | How a write should treat embedded album art+data AlbumArtUpdate+  = KeepExistingArt      -- ^ carry any existing art through unchanged+                         --   (including multiple pictures, verbatim)+  | SetAlbumArt AlbumArt -- ^ replace all existing art with this picture+  | RemoveAlbumArt       -- ^ strip all embedded art+  deriving (Show, Eq)+ -- | Complete metadata for an audio file data Metadata = Metadata   { format :: AudioFormat@@ -144,7 +153,9 @@   , musicBrainzIds :: MusicBrainzIds   , acoustidFingerprint :: Maybe Text  -- Chromaprint/AcoustID fingerprint   , acoustidId :: Maybe Text           -- AcoustID identifier-  , rawTags :: HashMap Text Text  -- All raw tags from the file+  , rawTags :: HashMap Text [Text]  -- All raw tags from the file; a key+                                    -- may carry several values (e.g.+                                    -- repeated Vorbis ARTIST comments)   } deriving (Show, Eq)  -- | Empty metadata with only format specified

@@ -10,10 +10,14 @@ import Control.Monad.Except (throwError) import Control.Monad.IO.Class (liftIO) import Data.Binary.Get+import Data.Bits ((.&.), shiftL)+import Data.Int (Int32)+import Data.Maybe (listToMaybe)+import Data.Word (Word64) import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy as L-import System.IO (Handle, IOMode(..), hSeek, SeekMode(..))+import System.IO (Handle, IOMode(..), hFileSize, hSeek, SeekMode(..)) import System.OsPath import System.File.OsPath (withBinaryFile) import qualified Data.HashMap.Strict as HM@@ -29,7 +33,14 @@ oggPageHeaderSize :: Int oggPageHeaderSize = 27 --- | Parse OGG file efficiently - only read metadata pages+-- | Refuse to reassemble packets beyond this size (a comment packet with+-- embedded art is a few MB; this only guards against malformed lacing)+maxPacketSize :: Int+maxPacketSize = 64 * 1024 * 1024++-- | Parse OGG file efficiently - only the first two logical packets are+-- read: the identification header and the comment header (this layout is+-- shared by Vorbis and Opus) parseOGG :: OsPath -> Parser Metadata parseOGG filePath = do   result <- liftIO $ withBinaryFile filePath ReadMode $ \handle -> do@@ -38,62 +49,142 @@     if BS.length firstHeader < 27 || BS.take 4 firstHeader /= "OggS"       then return $ Left $ UnsupportedFormat "Not an OGG file"       else do-        -- Parse pages until we find what we need         hSeek handle AbsoluteSeek 0-        metadata <- parseOggPages handle (emptyMetadata OGG) False False-        return $ Right metadata-  +        packets <- readFirstPackets handle 2+        let metadata = foldl (flip applyPacket) (emptyMetadata OGG) packets+        maybeGranule <- findLastGranule handle+        return $ Right $ applyDuration packets maybeGranule metadata+   case result of     Left err -> throwError err     Right m -> return m --- | Parse OGG pages looking for Vorbis headers-parseOggPages :: Handle -> Metadata -> Bool -> Bool -> IO Metadata-parseOggPages handle metadata foundIdent foundComment-  -- Stop when we have both headers-  | foundIdent && foundComment = return metadata-  | otherwise = do-      -- Read page header-      headerBytes <- BS.hGet handle oggPageHeaderSize-      -      if BS.length headerBytes < oggPageHeaderSize-        then return metadata  -- EOF+-- | Duration comes from the last page's granule position: total samples+-- for Vorbis, 48kHz sample count (including pre-skip) for Opus+applyDuration :: [BS.ByteString] -> Maybe Word64 -> Metadata -> Metadata+applyDuration packets maybeGranule metadata =+  case (maybeGranule, codec (audioProperties metadata)) of+    (Just granule, Just CodecOpus) ->+      setDuration (fromIntegral granule - opusPreSkip) 48000+    (Just granule, Just CodecVorbis) ->+      case sampleRate (audioProperties metadata) of+        Just rate | rate > 0 -> setDuration (fromIntegral granule) rate+        _ -> metadata+    _ -> metadata+  where+    setDuration :: Int -> Int -> Metadata+    setDuration samples rate+      | samples <= 0 = metadata+      | otherwise =+          let ms = round (fromIntegral samples * 1000 / fromIntegral rate :: Double)+          in metadata { audioProperties = (audioProperties metadata) { duration = Just ms } }++    opusPreSkip :: Int+    opusPreSkip = case [p | p <- packets, "OpusHead" `BS.isPrefixOf` p] of+      (p:_) | BS.length p >= 12 ->+        fromIntegral (BS.index p 10) + 256 * fromIntegral (BS.index p 11)+      _ -> 0++-- | Granule position of the file's last page (read from the tail without+-- scanning the whole file). Pages with the "no packet ends here" sentinel+-- granule (-1) are skipped.+findLastGranule :: Handle -> IO (Maybe Word64)+findLastGranule handle = do+  fileSize <- hFileSize handle+  let readLen = fromIntegral (min fileSize 65536)+  hSeek handle SeekFromEnd (negate (fromIntegral readLen))+  tailBytes <- BS.hGet handle readLen+  return $ case [g | off <- pageOffsets tailBytes+                   , Just g <- [granuleAt tailBytes off]+                   , g /= maxBound] of+    [] -> Nothing+    granules -> Just (last granules)+  where+    pageOffsets bs = go 0+      where+        go from = case BS.breakSubstring "OggS" (BS.drop from bs) of+          (before, rest)+            | BS.null rest -> []+            | otherwise ->+                let off = from + BS.length before+                in off : go (off + 4)++    granuleAt bs off+      | off + 14 > BS.length bs = Nothing+      | otherwise = Just $ sum+          [ fromIntegral (BS.index bs (off + 6 + i)) `shiftL` (8 * i) | i <- [0 .. 7] ]++-- | Apply a metadata packet to the metadata being built+applyPacket :: BS.ByteString -> Metadata -> Metadata+applyPacket packet metadata+  | "\x01vorbis" `BS.isPrefixOf` packet = parseVorbisInfo packet metadata+  | "OpusHead" `BS.isPrefixOf` packet = parseOpusInfo packet metadata+  | otherwise = case commentPayload packet of+      Just payload -> case runGetOrFail (parseVorbisCommentGet metadata) payload of+        Left _ -> metadata+        Right (_, _, result) -> result+      Nothing -> metadata++-- | Strip the header magic from a comment packet, if it is one. Vorbis and+-- Opus comment packets share the Vorbis comment structure after the magic+commentPayload :: BS.ByteString -> Maybe L.ByteString+commentPayload packet+  | "\x03vorbis" `BS.isPrefixOf` packet = Just $ L.fromStrict $ BS.drop 7 packet+  | "OpusTags" `BS.isPrefixOf` packet = Just $ L.fromStrict $ BS.drop 8 packet+  | otherwise = Nothing++-- | Read the first n complete logical packets of an OGG stream,+-- reassembling packets that span multiple segments and pages: a packet is+-- the concatenation of consecutive segments up to and including the first+-- segment shorter than 255 bytes, and may continue across pages (header+-- flag 0x01 on the continuing page)+readFirstPackets :: Handle -> Int -> IO [BS.ByteString]+readFirstPackets handle limit = goPage [] []+  where+    -- completed and partial both hold newest-first chunks+    goPage completed partial+      | length completed >= limit = return $ take limit $ reverse completed+      | otherwise = do+          maybePage <- readOggPage handle+          case maybePage of+            Nothing -> return $ take limit $ reverse completed  -- EOF or corrupt page+            Just (continued, segments) -> do+              -- A page that does not continue a packet implicitly abandons+              -- any leftover partial data (malformed stream)+              let partial0 = if continued then partial else []+                  (completed', partial') = foldl step (completed, partial0) segments+              if sum (map BS.length partial') > maxPacketSize+                then return $ take limit $ reverse completed'+                else goPage completed' partial'++    step (completed, partial) (segmentData, endsPacket)+      | endsPacket = (BS.concat (reverse (segmentData : partial)) : completed, [])+      | otherwise = (completed, segmentData : partial)++-- | Read one OGG page: the continuation flag and the segments with a marker+-- for whether each segment ends a packet (lacing value < 255)+readOggPage :: Handle -> IO (Maybe (Bool, [(BS.ByteString, Bool)]))+readOggPage handle = do+  headerBytes <- BS.hGet handle oggPageHeaderSize+  if BS.length headerBytes < oggPageHeaderSize || BS.take 4 headerBytes /= "OggS"+    then return Nothing+    else do+      let continued = BS.index headerBytes 5 .&. 0x01 /= 0+          numSegments = fromIntegral $ BS.index headerBytes 26+      segmentTable <- BS.hGet handle numSegments+      if BS.length segmentTable < numSegments+        then return Nothing         else do-          -- Verify OGG page signature-          if BS.take 4 headerBytes /= "OggS"-            then return metadata  -- Invalid page, stop-            else do-              -- Parse header to get segment table size-              let numSegments = fromIntegral $ BS.index headerBytes 26-              -              -- Read segment table-              segmentTable <- BS.hGet handle numSegments-              -              -- Calculate total page data size-              let pageDataSize = sum $ map fromIntegral $ BS.unpack segmentTable-              -              -- For the first few pages, read and check for Vorbis headers-              -- Vorbis headers are always in the first 3 pages-              if not foundIdent || not foundComment-                then do-                  pageData <- BS.hGet handle pageDataSize-                  -                  -- Check packet type-                  let (newMetadata, newFoundIdent, newFoundComment) =-                        if "\x01vorbis" `BS.isPrefixOf` pageData && not foundIdent-                        then (parseVorbisInfo pageData metadata, True, 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)-                  -                  -- Continue to next page-                  parseOggPages handle newMetadata newFoundIdent newFoundComment-                else do-                  -- Skip this page's data since we have what we need-                  hSeek handle RelativeSeek (fromIntegral pageDataSize)-                  return metadata+          let lacings = map fromIntegral $ BS.unpack segmentTable :: [Int]+          pageData <- BS.hGet handle (sum lacings)+          if BS.length pageData < sum lacings+            then return Nothing+            else return $ Just (continued, splitSegments lacings pageData)+  where+    splitSegments [] _ = []+    splitSegments (lacing:rest) bs =+      let (segment, unread) = BS.splitAt lacing bs+      in (segment, lacing < 255) : splitSegments rest unread  -- | Parse Vorbis identification header (packet type 1) parseVorbisInfo :: BS.ByteString -> Metadata -> Metadata@@ -111,11 +202,12 @@   _ <- getWord32le  -- vorbisVersion   audioChannels <- getWord8   audioSampleRate <- getWord32le-  bitrateMaximum <- getWord32le-  bitrateNominal <- getWord32le-  bitrateMinimum <- getWord32le-  -  -- The nominal bitrate is the average bitrate+  -- The bitrate fields are signed per the Vorbis spec; -1 means "unset"+  -- and must not be treated as a huge unsigned value+  bitrateMaximum <- fromIntegral <$> getWord32le :: Get Int32+  bitrateNominal <- fromIntegral <$> getWord32le :: Get Int32+  bitrateMinimum <- fromIntegral <$> getWord32le :: Get Int32+   let bitrate' = if bitrateNominal > 0                 then Just $ fromIntegral $ bitrateNominal `div` 1000                 else if bitrateMaximum > 0 && bitrateMinimum > 0@@ -149,26 +241,19 @@   _ <- getWord8            -- version   opusChannels <- getWord8   _ <- getWord16le         -- pre-skip-  inputSampleRate <- getWord32le  -- original sample rate before Opus resampled to 48k+  _ <- getWord32le         -- input sample rate (informational only, RFC 7845)   return $ metadata     { audioProperties = emptyAudioProperties-      { sampleRate = Just $ fromIntegral inputSampleRate+      -- Opus always decodes at 48kHz; the header's input rate is just a+      -- record of what the encoder was fed+      { sampleRate = Just 48000       , channels = Just $ fromIntegral opusChannels       , codec = Just CodecOpus       }     } --- | Parse Vorbis comment (packet type 3)-parseVorbisComment :: BS.ByteString -> Metadata -> Metadata-parseVorbisComment bs metadata =-  if BS.length bs < 7-    then metadata-    else-      let lazyBs = L.fromStrict bs-      in case runGetOrFail (parseVorbisCommentGet metadata) (L.drop 7 lazyBs) of-        Left _ -> metadata-        Right (_, _, result) -> result-+-- | Parse the Vorbis comment structure (shared by Vorbis and Opus, after+-- the packet magic has been stripped) parseVorbisCommentGet :: Metadata -> Get Metadata parseVorbisCommentGet metadata = do   -- Read vendor string length (little-endian 32-bit)@@ -181,42 +266,45 @@      -- Read each comment   comments <- parseCommentList (fromIntegral numComments)-  -  -- Convert to HashMap for efficient lookup-  let tagMap = HM.fromList comments-  ++  -- Vorbis comments may repeat a key (e.g. several ARTIST entries); keep+  -- every value. The scalar metadata fields take the first one.+  let tagMap = HM.fromListWith (flip (<>)) [(k, [v]) | (k, v) <- comments]+      firstOf key = HM.lookup key tagMap >>= listToMaybe+   -- Extract standard fields   return $ metadata-    { title = HM.lookup "TITLE" tagMap-    , artist = HM.lookup "ARTIST" tagMap-    , album = HM.lookup "ALBUM" tagMap-    , albumArtist = HM.lookup "ALBUMARTIST" tagMap-    , year = (HM.lookup "YEAR" tagMap >>= readInt)-             <|> (HM.lookup "DATE" tagMap >>= extractYearFromDate)-    , date = HM.lookup "DATE" tagMap-    , comment = HM.lookup "COMMENT" tagMap-    , genre = HM.lookup "GENRE" tagMap-    , trackNumber = HM.lookup "TRACKNUMBER" tagMap >>= readInt-    , totalTracks = HM.lookup "TRACKTOTAL" tagMap >>= readInt-    , discNumber = HM.lookup "DISCNUMBER" tagMap >>= readInt-    , totalDiscs = HM.lookup "DISCTOTAL" tagMap >>= readInt-    , releaseCountry = HM.lookup "RELEASECOUNTRY" tagMap-    , recordLabel = HM.lookup "LABEL" tagMap-    , catalogNumber = HM.lookup "CATALOGNUMBER" tagMap-    , barcode = HM.lookup "BARCODE" tagMap-    , releaseStatus = HM.lookup "RELEASESTATUS" tagMap-    , releaseType = HM.lookup "RELEASETYPE" tagMap-    , albumArtInfo = HM.lookup "METADATA_BLOCK_PICTURE" tagMap >>= parseVorbisPictureInfo+    { title = firstOf "TITLE"+    , artist = firstOf "ARTIST"+    , album = firstOf "ALBUM"+    , albumArtist = firstOf "ALBUMARTIST"+    , year = (firstOf "YEAR" >>= readInt)+             <|> (firstOf "DATE" >>= extractYearFromDate)+    , date = firstOf "DATE"+    , comment = firstOf "COMMENT"+    , genre = firstOf "GENRE"+    , trackNumber = firstOf "TRACKNUMBER" >>= readInt+    , totalTracks = firstOf "TRACKTOTAL" >>= readInt+    , discNumber = firstOf "DISCNUMBER" >>= readInt+    , totalDiscs = firstOf "DISCTOTAL" >>= readInt+    , releaseCountry = firstOf "RELEASECOUNTRY"+    , recordLabel = firstOf "LABEL"+    , catalogNumber = firstOf "CATALOGNUMBER"+    , barcode = firstOf "BARCODE"+    , releaseStatus = firstOf "RELEASESTATUS"+    , releaseType = firstOf "RELEASETYPE"+    , albumArtInfo = firstOf "METADATA_BLOCK_PICTURE" >>= parseVorbisPictureInfo     , musicBrainzIds = MusicBrainzIds-      { mbTrackId = HM.lookup "MUSICBRAINZ_RELEASETRACKID" tagMap-      , mbRecordingId = HM.lookup "MUSICBRAINZ_TRACKID" tagMap-      , mbReleaseId = HM.lookup "MUSICBRAINZ_ALBUMID" tagMap-      , mbReleaseGroupId = HM.lookup "MUSICBRAINZ_RELEASEGROUPID" tagMap-      , mbArtistId = HM.lookup "MUSICBRAINZ_ARTISTID" tagMap-      , mbAlbumArtistId = HM.lookup "MUSICBRAINZ_ALBUMARTISTID" tagMap-      , mbWorkId = HM.lookup "MUSICBRAINZ_WORKID" tagMap-      , mbDiscId = HM.lookup "MUSICBRAINZ_DISCID" tagMap+      { mbTrackId = firstOf "MUSICBRAINZ_RELEASETRACKID"+      , mbRecordingId = firstOf "MUSICBRAINZ_TRACKID"+      , mbReleaseId = firstOf "MUSICBRAINZ_ALBUMID"+      , mbReleaseGroupId = firstOf "MUSICBRAINZ_RELEASEGROUPID"+      , mbArtistId = firstOf "MUSICBRAINZ_ARTISTID"+      , mbAlbumArtistId = firstOf "MUSICBRAINZ_ALBUMARTISTID"+      , mbWorkId = firstOf "MUSICBRAINZ_WORKID"+      , mbDiscId = firstOf "MUSICBRAINZ_DISCID"       }+    , rawTags = tagMap     }   where     parseCommentList :: Int -> Get [(Text, Text)]@@ -277,61 +365,24 @@ -- | Load album art from OGG file (full binary data for writing) loadAlbumArtOGG :: OsPath -> Parser (Maybe AlbumArt) loadAlbumArtOGG filePath = do-  result <- liftIO $ withBinaryFile filePath ReadMode $ \handle -> do+  liftIO $ withBinaryFile filePath ReadMode $ \handle -> do     -- Read first page to check OGG signature     firstHeader <- BS.hGet handle 27     if BS.length firstHeader < 27 || BS.take 4 firstHeader /= "OggS"-      then return $ Right Nothing+      then return Nothing       else do-        -- Parse pages looking for Vorbis comment with METADATA_BLOCK_PICTURE+        -- The comment packet is the second logical packet in the stream         hSeek handle AbsoluteSeek 0-        Right <$> searchForPicture handle False False--  case result of-    Left err -> throwError err-    Right maybeArt -> return maybeArt+        packets <- readFirstPackets handle 2+        return $ case [p | packet <- packets, Just p <- [commentPayload packet]] of+          (payload:_) -> extractPictureFromComment payload+          [] -> Nothing   where-    searchForPicture :: Handle -> Bool -> Bool -> IO (Maybe AlbumArt)-    searchForPicture handle foundIdent foundComment-      | foundIdent && foundComment = return Nothing  -- Checked all metadata, no picture-      | otherwise = do-          headerBytes <- BS.hGet handle oggPageHeaderSize-          if BS.length headerBytes < oggPageHeaderSize-            then return Nothing-            else do-              if BS.take 4 headerBytes /= "OggS"-                then return Nothing-                else do-                  let numSegments = fromIntegral $ BS.index headerBytes 26-                  segmentTable <- BS.hGet handle numSegments-                  let pageDataSize = sum $ map fromIntegral $ BS.unpack segmentTable--                  if not foundIdent || not foundComment-                    then do-                      pageData <- BS.hGet handle pageDataSize-                      let (newFoundIdent, newFoundComment, maybePicture) =-                            if "\x01vorbis" `BS.isPrefixOf` pageData && not foundIdent-                            then (True, foundComment, Nothing)-                            else if "\x03vorbis" `BS.isPrefixOf` pageData && not foundComment-                            then (foundIdent, True, extractPictureFromComment pageData)-                            else (foundIdent, foundComment, Nothing)--                      case maybePicture of-                        Just art -> return (Just art)-                        Nothing -> searchForPicture handle newFoundIdent newFoundComment-                    else do-                      hSeek handle RelativeSeek (fromIntegral pageDataSize)-                      return Nothing--    extractPictureFromComment :: BS.ByteString -> Maybe AlbumArt-    extractPictureFromComment bs =-      if BS.length bs < 7-        then Nothing-        else-          let lazyBs = L.fromStrict bs-          in case runGetOrFail (parseVorbisCommentForPicture) (L.drop 7 lazyBs) of-            Left _ -> Nothing-            Right (_, _, result) -> result+    extractPictureFromComment :: L.ByteString -> Maybe AlbumArt+    extractPictureFromComment payload =+      case runGetOrFail parseVorbisCommentForPicture payload of+        Left _ -> Nothing+        Right (_, _, result) -> result      parseVorbisCommentForPicture :: Get (Maybe AlbumArt)     parseVorbisCommentForPicture = do@@ -346,9 +397,10 @@       commentLength <- getWord32le       commentBytes <- getByteString (fromIntegral commentLength)       case BS.split 0x3D commentBytes of-        (key:value:_) ->+        (key:value:rest) ->+          -- Rejoin on '=' so base64 padding at the end of the value survives           let keyText = T.toUpper $ TE.decodeUtf8With TEE.lenientDecode key-              valueText = TE.decodeUtf8With TEE.lenientDecode value+              valueText = TE.decodeUtf8With TEE.lenientDecode (BS.intercalate "=" (value:rest))           in if keyText == "METADATA_BLOCK_PICTURE"              then return $ parseVorbisPictureFull valueText              else findPictureComment (n - 1)

@@ -0,0 +1,298 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Write Vorbis/Opus tags into an OGG container.+--+-- The comment packet is rebuilt and repaginated, which can change the+-- number of header pages; every following page therefore gets its+-- sequence number rewritten and its CRC recomputed. Audio data itself is+-- copied verbatim.+module Monatone.OGG.Writer+  ( writeOGGMetadata+  , WriteError(..)+  , Writer+  ) where++import Control.Exception (catch, IOException)+import Control.Monad (unless)+import Control.Monad.Except (ExceptT, throwError, runExceptT)+import Control.Monad.IO.Class (liftIO)+import Data.Binary.Put+import Data.Bits (shiftL, shiftR, testBit, xor, (.&.), (.|.))+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Lazy as L+import qualified Data.HashMap.Strict as HM+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Word+import System.IO hiding (withBinaryFile)+import System.OsPath+import System.File.OsPath (withBinaryFile)+import System.IO.Temp (withSystemTempFile)++import Monatone.Metadata+import Monatone.FLAC.Writer (generateVorbisComments, renderPictureData)++-- Re-define WriteError and Writer locally to avoid circular imports+data WriteError+  = WriteIOError Text+  | UnsupportedWriteFormat AudioFormat+  | InvalidMetadata Text+  | CorruptedWrite Text+  deriving (Show, Eq)++type Writer = ExceptT WriteError IO++-- | Write metadata to an OGG (Vorbis or Opus) file+writeOGGMetadata :: Metadata -> AlbumArtUpdate -> OsPath -> Writer ()+writeOGGMetadata metadata artUpdate filePath = do+  result <- liftIO $ tryIO $ do+    withSystemTempFile "monatone-ogg.tmp" $ \tmpPath tmpHandle -> do+      hClose tmpHandle+      tmpOsPath <- encodeFS tmpPath+      rewriteResult <- withBinaryFile filePath ReadMode $ \srcHandle ->+        withBinaryFile tmpOsPath WriteMode $ \dstHandle ->+          runExceptT $ rewriteOGGFile srcHandle dstHandle metadata artUpdate+      case rewriteResult of+        Left err -> return $ Left err+        Right () -> do+          copyFileContents tmpOsPath filePath+          return $ Right ()++  case result of+    Left (e :: IOException) -> throwError $ WriteIOError $ T.pack $ show e+    Right (Left err) -> throwError err+    Right (Right ()) -> return ()+  where+    tryIO :: IO a -> IO (Either IOException a)+    tryIO action = catch (Right <$> action) (return . Left)++-- | Copy file contents+copyFileContents :: OsPath -> OsPath -> IO ()+copyFileContents src dst =+  withBinaryFile src ReadMode $ \srcHandle ->+    withBinaryFile dst WriteMode $ \dstHandle ->+      let loop = do+            chunk <- BS.hGet srcHandle 65536+            unless (BS.null chunk) $ do+              BS.hPut dstHandle chunk+              loop+      in loop++-- | One raw OGG page, split into its parts+data RawPage = RawPage+  { rpHeader :: ByteString    -- 27 bytes+  , rpSegTable :: ByteString+  , rpData :: ByteString+  }++rpContinued :: RawPage -> Bool+rpContinued page = BS.index (rpHeader page) 5 .&. 0x01 /= 0++rpSerial :: RawPage -> ByteString+rpSerial page = BS.take 4 $ BS.drop 14 $ rpHeader page++-- | Segments with an ends-packet marker (lacing value < 255)+rpSegments :: RawPage -> [(ByteString, Bool)]+rpSegments page = go (map fromIntegral (BS.unpack (rpSegTable page))) (rpData page)+  where+    go [] _ = []+    go (lacing:rest) bs =+      let (segment, unread) = BS.splitAt lacing bs+      in (segment, lacing < 255) : go rest unread++readRawPage :: Handle -> IO (Maybe RawPage)+readRawPage handle = do+  header <- BS.hGet handle 27+  if BS.length header < 27 || BS.take 4 header /= "OggS"+    then return Nothing+    else do+      let numSegments = fromIntegral $ BS.index header 26+      segTable <- BS.hGet handle numSegments+      let dataSize = sum $ map fromIntegral $ BS.unpack segTable+      pageData <- BS.hGet handle dataSize+      if BS.length segTable < numSegments || BS.length pageData < dataSize+        then return Nothing+        else return $ Just $ RawPage header segTable pageData++-- | Rewrite the OGG stream with a new comment packet+rewriteOGGFile :: Handle -> Handle -> Metadata -> AlbumArtUpdate -> Writer ()+rewriteOGGFile srcHandle dstHandle metadata artUpdate = do+  -- Page 0 carries the identification packet alone; copy it verbatim+  maybeFirst <- liftIO $ readRawPage srcHandle+  firstPage <- case maybeFirst of+    Nothing -> throwError $ CorruptedWrite "Not an OGG file"+    Just page -> return page+  let identPacket = BS.concat (map fst (rpSegments firstPage))++  -- Vorbis has a setup packet after the comment; Opus does not+  (commentMagic, trailingHeaderPackets) <-+    if "\x01vorbis" `BS.isPrefixOf` identPacket then return ("\x03vorbis", 1)+    else if "OpusHead" `BS.isPrefixOf` identPacket then return ("OpusTags", 0)+    else throwError $ UnsupportedWriteFormat OGG++  -- Recompute the CRC rather than trusting the source's+  let firstRaw = rpHeader firstPage <> rpSegTable firstPage <> rpData firstPage+  liftIO $ BS.hPut dstHandle $ patchCrc $+    BS.take 22 firstRaw <> BS.replicate 4 0 <> BS.drop 26 firstRaw++  -- Collect the remaining header packets (comment [+ setup])+  headerPackets <- collectHeaderPackets srcHandle (1 + trailingHeaderPackets)+  (oldComment, setupPackets) <- case headerPackets of+    (c:rest) -> return (c, rest)+    [] -> throwError $ CorruptedWrite "Missing comment header packet"++  -- Build the new comment packet, keeping the original vendor string+  let newComment = buildCommentPacket commentMagic (extractVendor commentMagic oldComment)+        metadata artUpdate++  -- Repaginate the header packets, then stream the audio pages through+  -- with renumbered sequence numbers and recomputed CRCs+  nextSeqno <- liftIO $ writeHeaderPages dstHandle (rpSerial firstPage) (newComment : setupPackets)+  liftIO $ rewriteAudioPages srcHandle dstHandle nextSeqno++-- | Read pages after the first, reassembling exactly n packets. The+-- header packets must end on a page boundary (they do in spec-conformant+-- streams); anything else would interleave audio into the header pages.+collectHeaderPackets :: Handle -> Int -> Writer [ByteString]+collectHeaderPackets handle n = go [] []+  where+    go :: [ByteString] -> [ByteString] -> Writer [ByteString]+    go completed partial+      | length completed >= n =+          if null partial && length completed == n+            then return $ reverse completed+            else throwError $ CorruptedWrite "Header packets do not end on a page boundary"+      | otherwise = do+          maybePage <- liftIO $ readRawPage handle+          case maybePage of+            Nothing -> throwError $ CorruptedWrite "Truncated OGG header pages"+            Just page -> do+              let partial0 = if rpContinued page then partial else []+                  (completed', partial') = foldl step (completed, partial0) (rpSegments page)+              go completed' partial'++    step (completed, partial) (segmentData, endsPacket)+      | endsPacket = (BS.concat (reverse (segmentData : partial)) : completed, [])+      | otherwise = (completed, segmentData : partial)++-- | The vendor string sits right after the packet magic+extractVendor :: ByteString -> ByteString -> ByteString+extractVendor magic packet =+  let body = BS.drop (BS.length magic) packet+      vendorLen = word32leAt body+      vendor = BS.take vendorLen (BS.drop 4 body)+  in if BS.length body >= 4 && BS.length vendor == vendorLen then vendor else ""+  where+    word32leAt bs+      | BS.length bs < 4 = 0+      | otherwise = sum [fromIntegral (BS.index bs i) `shiftL` (8 * i) | i <- [0 .. 3]]++-- | Build the comment packet: magic, vendor, comments (art included as a+-- base64 METADATA_BLOCK_PICTURE comment), and Vorbis's framing bit+buildCommentPacket :: ByteString -> ByteString -> Metadata -> AlbumArtUpdate -> ByteString+buildCommentPacket magic vendor metadata artUpdate =+  let comments = generateVorbisComments metadata ++ artComments+      renderComment (key, value) =+        let bytes = TE.encodeUtf8 (key <> "=" <> value)+        in w32le (BS.length bytes) <> bytes+      framing = if magic == "\x03vorbis" then BS.singleton 0x01 else BS.empty+  in BS.concat $+       [magic, w32le (BS.length vendor), vendor, w32le (length comments)]+       ++ map renderComment comments+       ++ [framing]+  where+    artComments :: [(Text, Text)]+    artComments = case artUpdate of+      KeepExistingArt ->+        [ ("METADATA_BLOCK_PICTURE", value)+        | value <- HM.lookupDefault [] "METADATA_BLOCK_PICTURE" (rawTags metadata)+        ]+      SetAlbumArt art ->+        [("METADATA_BLOCK_PICTURE", TE.decodeUtf8 (B64.encode (L.toStrict (renderPictureData art))))]+      RemoveAlbumArt -> []++-- | Paginate packets into header pages (granule 0) starting at sequence+-- number 1; returns the next free sequence number+writeHeaderPages :: Handle -> ByteString -> [ByteString] -> IO Word32+writeHeaderPages handle serial packets = go 1 False (pagesOf (concatMap packetSegments packets))+  where+    go seqno _ [] = return seqno+    go seqno continued (pageSegments : rest) = do+      BS.hPut handle $ renderPage continued seqno pageSegments+      let nextContinued = case reverse pageSegments of+            (lastSegment:_) -> BS.length lastSegment == 255+            [] -> False+      go (seqno + 1) nextContinued rest++    -- Segments of one packet: 255-byte chunks with a final short one+    -- (empty when the length is a multiple of 255)+    packetSegments packet =+      let (chunk, rest) = BS.splitAt 255 packet+      in if BS.length chunk == 255+           then chunk : packetSegments rest+           else [chunk]++    pagesOf [] = []+    pagesOf segments = let (page, rest) = splitAt 255 segments in page : pagesOf rest++    renderPage continued seqno segments =+      let flags = if continued then 0x01 else 0x00+          headerNoCrc = BS.concat+            [ "OggS"+            , BS.singleton 0                                   -- version+            , BS.singleton flags+            , BS.replicate 8 0                                 -- granule position+            , serial+            , w32le (fromIntegral seqno)+            , BS.replicate 4 0                                 -- CRC placeholder+            , BS.singleton (fromIntegral (length segments))+            , BS.pack (map (fromIntegral . BS.length) segments)+            ]+          page = headerNoCrc <> BS.concat segments+      in patchCrc page++-- | Copy the remaining pages, renumbering sequence numbers (the header+-- page count may have changed) and recomputing CRCs. Trailing bytes that+-- do not parse as a page are copied verbatim.+rewriteAudioPages :: Handle -> Handle -> Word32 -> IO ()+rewriteAudioPages srcHandle dstHandle seqno = do+  pos <- hTell srcHandle+  maybePage <- readRawPage srcHandle+  case maybePage of+    Just page -> do+      let raw = rpHeader page <> rpSegTable page <> rpData page+          renumbered = BS.take 18 raw <> w32le (fromIntegral seqno)+            <> BS.replicate 4 0 <> BS.drop 26 raw+      BS.hPut dstHandle $ patchCrc renumbered+      rewriteAudioPages srcHandle dstHandle (seqno + 1)+    Nothing -> do+      -- copy whatever is left verbatim+      hSeek srcHandle AbsoluteSeek pos+      let loop = do+            chunk <- BS.hGet srcHandle 65536+            unless (BS.null chunk) $ do+              BS.hPut dstHandle chunk+              loop+      loop++-- | Compute the page CRC (bytes 22-25 must be zero) and patch it in+patchCrc :: ByteString -> ByteString+patchCrc page =+  BS.take 22 page <> w32le (fromIntegral (oggCrc page)) <> BS.drop 26 page++-- | The OGG page checksum: CRC-32 with polynomial 0x04c11db7, no+-- reflection, zero initial value and no final xor+oggCrc :: ByteString -> Word32+oggCrc = BS.foldl' step 0+  where+    step crc byte = go (8 :: Int) (crc `xor` (fromIntegral byte `shiftL` 24))+    go 0 crc = crc+    go n crc = go (n - 1) $+      if testBit crc 31 then (crc `shiftL` 1) `xor` 0x04c11db7 else crc `shiftL` 1++w32le :: Int -> ByteString+w32le n = BS.pack [fromIntegral (n `shiftR` s) | s <- [0, 8, 16, 24]]

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-}@@ -46,15 +47,18 @@ import System.Directory.OsPath (copyFile, renameFile, removeFile) import Control.Exception (try, IOException, evaluate) +#ifdef USE_UNIX_FSYNC+import System.Posix.IO (openFd, closeFd, defaultFileFlags, OpenMode(ReadWrite))+import System.Posix.Unistd (fileSynchronise)+import Control.Exception (bracket)+#endif+ import Monatone.Metadata-import Monatone.Types (Parser, ParseError(..))-import Monatone.Common (loadAlbumArt)-import qualified Monatone.MP3 as MP3-import qualified Monatone.FLAC as FLAC-import qualified Monatone.M4A as M4A+import Monatone.Common (parseMetadata) import qualified Monatone.MP3.Writer as MP3Writer import qualified Monatone.FLAC.Writer as FLACWriter import qualified Monatone.M4A.Writer as M4AWriter+import qualified Monatone.OGG.Writer as OGGWriter  -- | Write operation errors data WriteError@@ -249,8 +253,8 @@ -- 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+writeMetadata :: Metadata -> AlbumArtUpdate -> OsPath -> Writer ()+writeMetadata metadata artUpdate 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|]@@ -260,12 +264,21 @@     Left (ioErr :: IOException) ->       throwError $ WriteIOError $ "Failed to create temporary copy: " <> T.pack (show ioErr)     Right () -> do-      writeResult <- liftIO $ runExceptT $ dispatchWrite metadata maybeAlbumArt tmpPath+      writeResult <- liftIO $ runExceptT $ dispatchWrite metadata artUpdate tmpPath       case writeResult of         Left err -> do           discardTemp tmpPath           throwError err         Right () -> do+          -- Flush the temp file to stable storage before the rename+          -- commits it, so a power loss cannot leave a half-written+          -- file behind the new name+          syncResult <- liftIO $ try $ syncFile tmpPath+          case syncResult of+            Left (ioErr :: IOException) -> do+              discardTemp tmpPath+              throwError $ WriteIOError $ "Failed to sync file: " <> T.pack (show ioErr)+            Right () -> pure ()           renameResult <- liftIO $ try $ renameFile tmpPath filePath           case renameResult of             Left (ioErr :: IOException) -> do@@ -278,21 +291,32 @@       _ <- liftIO $ (try :: IO () -> IO (Either IOException ())) $ removeFile path       return () +-- | Flush a file's contents to stable storage (no-op where unsupported)+syncFile :: OsPath -> IO ()+#ifdef USE_UNIX_FSYNC+syncFile path = do+  fp <- decodeFS path+  bracket (openFd fp ReadWrite defaultFileFlags) closeFd fileSynchronise+#else+syncFile _ = return ()+#endif+ -- | 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-    FLAC -> writeFLACMetadata metadata maybeAlbumArt filePath-    M4A -> writeM4AMetadata metadata maybeAlbumArt filePath-    _ -> throwError $ UnsupportedWriteFormat audioFormat+dispatchWrite :: Metadata -> AlbumArtUpdate -> OsPath -> Writer ()+dispatchWrite metadata artUpdate filePath =+  case format metadata of+    MP3 -> writeMP3Metadata metadata artUpdate filePath+    FLAC -> writeFLACMetadata metadata artUpdate filePath+    M4A -> writeM4AMetadata metadata artUpdate filePath+    OGG -> writeOGGMetadata metadata artUpdate filePath+    Opus -> writeOGGMetadata metadata artUpdate filePath --- | Update existing file with metadata changes+-- | Update existing file with metadata changes. The format is detected+-- from the file content, not the extension. updateMetadata :: OsPath -> MetadataUpdate -> Writer () updateMetadata filePath update = do   -- Read existing metadata-  existingResult <- liftIO $ runExceptT $ parseFile filePath+  existingResult <- liftIO $ parseMetadata filePath   case existingResult of     Left parseErr -> throwError $ CorruptedWrite $ "Failed to read existing metadata: " <> T.pack (show parseErr)     Right existingMetadata -> do@@ -302,27 +326,20 @@       -- Force evaluation of the format field to ensure metadata is constructed       _ <- liftIO $ evaluate (format updatedMetadata) -      -- Determine album art to write-      maybeArt <- case updateAlbumArt update of-        Just Nothing -> return Nothing  -- Explicitly removing artwork-        Just (Just art) -> return (Just art)  -- Explicitly setting artwork-        Nothing -> do  -- No change to artwork - preserve existing-          case albumArtInfo existingMetadata of-            Nothing -> return Nothing  -- No existing artwork-            Just _ -> do-              -- Load existing artwork from file-              artResult <- liftIO $ loadAlbumArt filePath-              case artResult of-                Left _ -> return Nothing  -- Failed to load, continue without it-                Right art -> return art+      -- Album art: unchanged art is carried through verbatim by the+      -- format writers, so nothing needs to be reloaded here+      let artUpdate = case updateAlbumArt update of+            Nothing -> KeepExistingArt+            Just Nothing -> RemoveAlbumArt+            Just (Just art) -> SetAlbumArt art        -- Write back-      writeMetadata updatedMetadata maybeArt filePath+      writeMetadata updatedMetadata artUpdate filePath  -- | Write MP3 metadata using the MP3Writer module-writeMP3Metadata :: Metadata -> Maybe AlbumArt -> OsPath -> Writer ()-writeMP3Metadata metadata maybeAlbumArt filePath = do-  result <- liftIO $ runExceptT $ MP3Writer.writeMP3Metadata metadata maybeAlbumArt filePath+writeMP3Metadata :: Metadata -> AlbumArtUpdate -> OsPath -> Writer ()+writeMP3Metadata metadata artUpdate filePath = do+  result <- liftIO $ runExceptT $ MP3Writer.writeMP3Metadata metadata artUpdate filePath   case result of     Left mp3Err -> throwError $ convertMP3Error mp3Err     Right () -> return ()@@ -334,9 +351,9 @@     convertMP3Error (MP3Writer.CorruptedWrite msg) = CorruptedWrite msg  -- | Write FLAC metadata using the FLACWriter module-writeFLACMetadata :: Metadata -> Maybe AlbumArt -> OsPath -> Writer ()-writeFLACMetadata metadata maybeAlbumArt filePath = do-  result <- liftIO $ runExceptT $ FLACWriter.writeFLACMetadata metadata maybeAlbumArt filePath+writeFLACMetadata :: Metadata -> AlbumArtUpdate -> OsPath -> Writer ()+writeFLACMetadata metadata artUpdate filePath = do+  result <- liftIO $ runExceptT $ FLACWriter.writeFLACMetadata metadata artUpdate filePath   case result of     Left flacErr -> throwError $ convertFLACError flacErr     Right () -> return ()@@ -348,9 +365,9 @@     convertFLACError (FLACWriter.CorruptedWrite msg) = CorruptedWrite msg  -- | Write M4A metadata using the M4AWriter module-writeM4AMetadata :: Metadata -> Maybe AlbumArt -> OsPath -> Writer ()-writeM4AMetadata metadata maybeAlbumArt filePath = do-  result <- liftIO $ runExceptT $ M4AWriter.writeM4AMetadata metadata maybeAlbumArt filePath+writeM4AMetadata :: Metadata -> AlbumArtUpdate -> OsPath -> Writer ()+writeM4AMetadata metadata artUpdate filePath = do+  result <- liftIO $ runExceptT $ M4AWriter.writeM4AMetadata metadata artUpdate filePath   case result of     Left m4aErr -> throwError $ convertM4AError m4aErr     Right () -> return ()@@ -361,15 +378,17 @@     convertM4AError (M4AWriter.InvalidMetadata msg) = InvalidMetadata msg     convertM4AError (M4AWriter.CorruptedWrite msg) = CorruptedWrite msg --- | Parse file using existing parsers based on extension-parseFile :: OsPath -> Parser Metadata-parseFile filePath = do-  -- Convert extension to lowercase for comparison-  let ext = takeExtension filePath-  if ext == [osp|.mp3|] || ext == [osp|.MP3|]-    then MP3.parseMP3 filePath-    else if ext == [osp|.flac|] || ext == [osp|.FLAC|]-    then FLAC.parseFLAC filePath-    else if ext == [osp|.m4a|] || ext == [osp|.M4A|] || ext == [osp|.mp4|] || ext == [osp|.MP4|]-    then M4A.parseM4A filePath-    else throwError $ UnsupportedFormat "Unsupported file extension"+-- | Write OGG/Opus metadata using the OGGWriter module+writeOGGMetadata :: Metadata -> AlbumArtUpdate -> OsPath -> Writer ()+writeOGGMetadata metadata artUpdate filePath = do+  result <- liftIO $ runExceptT $ OGGWriter.writeOGGMetadata metadata artUpdate filePath+  case result of+    Left oggErr -> throwError $ convertOGGError oggErr+    Right () -> return ()+  where+    convertOGGError :: OGGWriter.WriteError -> WriteError+    convertOGGError (OGGWriter.WriteIOError msg) = WriteIOError msg+    convertOGGError (OGGWriter.UnsupportedWriteFormat fmt) = UnsupportedWriteFormat fmt+    convertOGGError (OGGWriter.InvalidMetadata msg) = InvalidMetadata msg+    convertOGGError (OGGWriter.CorruptedWrite msg) = CorruptedWrite msg+

@@ -7,6 +7,7 @@ import qualified Test.FLACSpec as FLAC import qualified Test.MP3Spec as MP3 import qualified Test.M4ASpec as M4A+import qualified Test.OGGSpec as OGG import qualified Test.WriterSpec as Writer import qualified Test.IntegrationSpec as Integration @@ -19,6 +20,7 @@       [ FLAC.tests       , MP3.tests       , M4A.tests+      , OGG.tests       , Writer.tests       ]   , Integration.tests

@@ -10,14 +10,15 @@ import System.FilePath ((</>)) import System.Directory (doesFileExist, copyFile, removeFile, getTemporaryDirectory) import System.Process (callProcess)-import Control.Exception (catch, SomeException)+import Control.Exception (catch, evaluate, SomeException) import Control.Monad (unless) import System.OsPath hiding ((</>))-import Data.Bits ((.&.), (.|.), shiftL)+import Data.Bits ((.&.), (.|.), shiftL, shiftR) import qualified Data.ByteString as BS import qualified Data.HashMap.Strict as HM import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as TE import Data.Word (Word8)  import Monatone.Common (parseMetadata)@@ -41,6 +42,53 @@     , testGroup "Write Safety"         [ testFailedWriteLeavesOriginalIntact         ]+    , localOption (mkTimeout 10000000) $ testGroup "Malformed Input"+        [ testMalformed "M4A with zero 64-bit atom size does not hang" "monatone-bad-size64.m4a" $+            atomBS "ftyp" ("M4A " <> w32 0)+              <> w32 1 <> "oops" <> w64 0  -- 64-bit size of zero+              <> BS.replicate 64 0xAA+        , testMalformed "M4A moov with zero-size child does not hang" "monatone-bad-child.m4a" $+            atomBS "ftyp" ("M4A " <> w32 0)+              <> atomBS "moov" (w32 0 <> "bad!" <> BS.replicate 16 0)+              <> atomBS "mdat" (BS.replicate 32 0xBB)+        , testMalformed "truncated FLAC STREAMINFO does not crash" "monatone-truncated.flac" $+            "fLaC" <> BS.pack [0x00, 0x00, 0x00, 34] <> BS.replicate 10 0+        , testMalformed "FLAC comment block with lying lengths does not crash" "monatone-lying.flac" $+            "fLaC"+              <> BS.pack [0x00, 0x00, 0x00, 34] <> BS.replicate 34 0     -- STREAMINFO+              <> BS.pack [0x84, 0x00, 0x00, 8]                           -- last block, type 4+              <> BS.pack [0xFF, 0xFF, 0xFF, 0xFF] <> BS.replicate 4 0    -- vendor length lies+        , testMalformed "MP3 frame sync at EOF does not crash" "monatone-sync-eof.mp3" $+            -- empty ID3v2 tag so format detection sees an MP3, then a sync+            -- pattern with fewer than 4 header bytes right at EOF+            "ID3" <> BS.pack [4, 0, 0, 0, 0, 0, 0]+              <> BS.replicate 116 0x00 <> BS.pack [0xFF, 0xE0]+        , testMalformedWrite "M4A writer handles zero 64-bit atom size without hanging" "monatone-bad-write.m4a" $+            atomBS "ftyp" ("M4A " <> w32 0)+              <> w32 1 <> "oops" <> w64 0+              <> BS.replicate 64 0xAA+        , testMalformedWrite "M4A writer handles zero-size moov child without hanging" "monatone-bad-child-write.m4a" $+            atomBS "ftyp" ("M4A " <> w32 0)+              <> atomBS "moov" (w32 0 <> "bad!" <> BS.replicate 16 0)+              <> atomBS "mdat" (BS.replicate 32 0xBB)+        ]+    , testGroup "Encoding and Spec Compliance"+        [ testUtf16Frames+        , testUnsyncTag+        , testID3v1Latin1+        , testMultiValueVorbis+        , testMultiValueID3+        , testMixedCaseExtension+        , testAlacProperties+        , testUFIDFrame+        , testID3v1Refresh+        , testNumericGenres+        ]+    , testGroup "Art and Binary Frame Preservation"+        [ testFLACMultiPicture+        , testMP3BinaryFrames+        , testM4ACovrPreservation+        ]     , testGroup "Tag Preservation"         [ testTagPreservation "MP3" "minimal.mp3"             [("TXXX:MyCustomTag", "custom-value"), ("TMOO", "Chill")]@@ -52,6 +100,399 @@         ]     ] +-- | Multiple FLAC PICTURE blocks survive an unrelated update verbatim;+-- setting art replaces them all; removing art strips them all+testFLACMultiPicture :: TestTree+testFLACMultiPicture = testCase "FLAC keeps all pictures unless art is edited" $ do+  let img1 = "IMAGEONEDATA" :: BS.ByteString+      img2 = "IMAGETWODATA" :: BS.ByteString+      picContent img = BS.concat+        [ w32 3, w32 9, "image/png", w32 0+        , w32 0, w32 0, w32 0, w32 0+        , w32 (BS.length img), img+        ]+      block btype content =+        BS.pack [btype, 0, 0, fromIntegral (BS.length content)] <> content+      markLast bs = BS.cons (BS.head bs .|. 0x80) (BS.tail bs)+      vorbis = BS.pack [0, 0, 0, 0] <> BS.pack [0, 0, 0, 0]  -- empty vendor + 0 comments+      bytes = "fLaC"+        <> block 0 (BS.replicate 34 0)+        <> block 4 vorbis+        <> block 6 (picContent img1)+        <> markLast (block 6 (picContent img2))++  path <- writeMalformed "monatone-multipic.flac" bytes+  osPath <- toOsPath path++  -- Unrelated update: both pictures survive verbatim+  runExceptT (updateMetadata osPath (setTitle "Pictures" emptyUpdate))+    >>= either (assertFailure . show) return+  afterTitle <- BS.readFile path+  let pics bs = [c | (6, c) <- flacBlocks bs]+  assertEqual "both pictures kept" [picContent img1, picContent img2] (pics afterTitle)++  -- Setting art replaces all pictures with the new one+  let newArt = AlbumArt "image/png" 3 "" "NEWIMAGEDATA"+  runExceptT (updateMetadata osPath (setAlbumArt newArt emptyUpdate))+    >>= either (assertFailure . show) return+  afterSet <- BS.readFile path+  assertEqual "one picture after set" 1 (length (pics afterSet))+  assertBool "new image present" ("NEWIMAGEDATA" `BS.isInfixOf` afterSet)++  -- Removing art strips all pictures+  runExceptT (updateMetadata osPath (removeAlbumArt emptyUpdate))+    >>= either (assertFailure . show) return+  afterRemove <- BS.readFile path+  assertEqual "no pictures after remove" [] (pics afterRemove)+  removeFile path++-- | MP3 frames that cannot be regenerated from text (USLT lyrics, PRIV,+-- APIC) are carried through an update verbatim+testMP3BinaryFrames :: TestTree+testMP3BinaryFrames = testCase "MP3 keeps binary frames through updates" $ do+  let lyrics = "These are the lyrics" :: BS.ByteString+      privPayload = "com.example.owner\0PRIVATEBLOB" <> BS.pack [1, 2, 0xFF, 0xFE]+      apicImage = "FAKEPNGIMAGEDATA" :: BS.ByteString+      tag = id3v24Tag+        [ frame24 "TIT2" (BS.singleton 3 <> "Old")+        , frame24 "USLT" (BS.singleton 3 <> "eng" <> BS.singleton 0 <> lyrics)+        , frame24 "PRIV" privPayload+        , frame24 "APIC" (BS.concat+            [ BS.singleton 3, "image/png", BS.singleton 0+            , BS.singleton 3, BS.singleton 0, apicImage+            ])+        ]+  path <- writeMalformed "monatone-binary-frames.mp3" tag+  osPath <- toOsPath path++  runExceptT (updateMetadata osPath (setTitle "New" emptyUpdate))+    >>= either (assertFailure . show) return+  afterTitle <- BS.readFile path+  assertBool "lyrics kept" (lyrics `BS.isInfixOf` afterTitle)+  assertBool "PRIV kept" (privPayload `BS.isInfixOf` afterTitle)+  assertBool "APIC kept" (apicImage `BS.isInfixOf` afterTitle)++  -- Removing art drops APIC but keeps the other binary frames+  runExceptT (updateMetadata osPath (removeAlbumArt emptyUpdate))+    >>= either (assertFailure . show) return+  afterRemove <- BS.readFile path+  assertBool "APIC removed" (not (apicImage `BS.isInfixOf` afterRemove))+  assertBool "lyrics still kept" (lyrics `BS.isInfixOf` afterRemove)+  removeFile path++-- | M4A cover art atoms are carried through an update verbatim+testM4ACovrPreservation :: TestTree+testM4ACovrPreservation = testCase "M4A keeps cover art through updates" $ do+  let img = "FAKEJPEGDATA123" :: BS.ByteString+      dataAtom dtype payload =+        w32 (16 + BS.length payload) <> "data" <> w32 dtype <> w32 0 <> payload+      ilst = atomBS "\169nam" (dataAtom 1 "Old")+        <> atomBS "covr" (dataAtom 13 img)+      moov = atomBS "moov" $ atomBS "udta" $ atomBS "meta" (w32 0 <> atomBS "ilst" ilst)+      bytes = atomBS "ftyp" ("M4A " <> w32 0) <> moov <> atomBS "mdat" (BS.replicate 16 0xCC)+  path <- writeMalformed "monatone-covr.m4a" bytes+  osPath <- toOsPath path++  runExceptT (updateMetadata osPath (setTitle "New" emptyUpdate))+    >>= either (assertFailure . show) return+  afterTitle <- BS.readFile path+  assertBool "cover art kept" (img `BS.isInfixOf` afterTitle)++  runExceptT (updateMetadata osPath (removeAlbumArt emptyUpdate))+    >>= either (assertFailure . show) return+  afterRemove <- BS.readFile path+  assertBool "cover art removed" (not (img `BS.isInfixOf` afterRemove))+  removeFile path++-- | 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++-- | Parsing a crafted malformed file must terminate without an uncaught+-- exception; either a clean parse error or best-effort metadata is fine.+-- The result is forced deeply (via show) because lazily deferred parse+-- errors would otherwise go unnoticed here and blow up in the caller.+testMalformed :: String -> FilePath -> BS.ByteString -> TestTree+testMalformed name fileName bytes = testCase name $ do+  path <- writeMalformed fileName bytes+  osPath <- toOsPath path+  result <- parseMetadata osPath+  removeFile path+  case result of+    Left _ -> return ()+    Right m -> do+      _ <- evaluate (length (show m))+      return ()++-- | Writing to a crafted malformed file must terminate - a clean error or+-- a best-effort write are both acceptable, hanging or throwing is not+testMalformedWrite :: String -> FilePath -> BS.ByteString -> TestTree+testMalformedWrite name fileName bytes = testCase name $ do+  path <- writeMalformed fileName bytes+  osPath <- toOsPath path+  result <- runExceptT $ writeMetadata (emptyMetadata M4A) KeepExistingArt osPath+  removeFile path+  case result of+    Left _ -> return ()+    Right () -> return ()++writeMalformed :: FilePath -> BS.ByteString -> IO FilePath+writeMalformed fileName bytes = do+  tmpDir <- getTemporaryDirectory+  let path = tmpDir </> fileName+  BS.writeFile path bytes+  return path++-- | UTF-16 COMM/TXXX descriptions end in an aligned double-null; an+-- unaligned terminator search shifts every following code unit and garbles+-- the value+testUtf16Frames :: TestTree+testUtf16Frames = testCase "UTF-16 frames with descriptions decode correctly" $ do+  let utf16 t = "\xFF\xFE" <> TE.encodeUtf16LE t  -- BOM + UTF-16LE+      txxxFrame = frame24 "TXXX" $+        BS.singleton 1 <> utf16 "Desc" <> BS.pack [0, 0] <> utf16 "Value"+      commFrame = frame24 "COMM" $+        BS.singleton 1 <> "eng" <> utf16 "note" <> BS.pack [0, 0] <> utf16 "Some comment"+  metadata <- parseCrafted "monatone-utf16.mp3" (id3v24Tag [txxxFrame, commFrame])+  assertEqual "TXXX value" (Just ["Value"]) (HM.lookup "TXXX:Desc" (rawTags metadata))+  assertEqual "COMM value" (Just "Some comment") (comment metadata)++-- | An ID3v2.3 tag with the unsynchronisation flag has 0x00 inserted after+-- every 0xFF; parsing without reversing that garbles UTF-16 content+testUnsyncTag :: TestTree+testUnsyncTag = testCase "ID3v2.3 unsynchronised tag is decoded" $ do+  let titleContent = BS.singleton 1 <> "\xFF\xFE" <> TE.encodeUtf16LE "Hi"+      body = frame23 "TIT2" titleContent+      unsynced = applyUnsync body+      tag = "ID3" <> BS.pack [3, 0, 0x80] <> syncsafe32 (BS.length unsynced) <> unsynced+  metadata <- parseCrafted "monatone-unsync.mp3" tag+  assertEqual "title" (Just "Hi") (title metadata)+  where+    applyUnsync = BS.concatMap (\b -> if b == 0xFF then BS.pack [0xFF, 0x00] else BS.singleton b)++-- | ID3v1 fields are Latin-1, not UTF-8+testID3v1Latin1 :: TestTree+testID3v1Latin1 = testCase "ID3v1 fields decode as Latin-1" $ do+  let v1Field n t = BS.take n (t <> BS.replicate n 0)+      v1Tag = "TAG"+        <> v1Field 30 "Caf\xE9"          -- title: "Café" in Latin-1+        <> v1Field 30 "Artist" <> v1Field 30 "Album"+        <> v1Field 4 "2001" <> v1Field 30 "Comment"+        <> BS.singleton 0                -- genre+      bytes = id3v24Tag [] <> BS.replicate 32 0 <> v1Tag+  metadata <- parseCrafted "monatone-latin1.mp3" bytes+  assertEqual "title" (Just "Café") (title metadata)++-- | Repeated Vorbis comment keys are kept as lists: the scalar field shows+-- the first value, rawTags holds them all, an unrelated update preserves+-- the whole list, and editing the field replaces the list+testMultiValueVorbis :: TestTree+testMultiValueVorbis = testCase "Multi-valued Vorbis comments are kept as lists" $ do+  let vorbisComment t = w32le (BS.length t) <> t+      comments = ["ARTIST=One", "ARTIST=Two", "TITLE=Multi"]+      vorbisBlock = w32le 0 <> w32le (length comments)+        <> BS.concat (map vorbisComment comments)+      bytes = "fLaC"+        <> BS.pack [0x00, 0x00, 0x00, 34] <> BS.replicate 34 0  -- STREAMINFO+        <> BS.pack [0x84, 0, 0] <> BS.singleton (fromIntegral (BS.length vorbisBlock))+        <> vorbisBlock++  path <- writeMalformed "monatone-multi.flac" bytes+  osPath <- toOsPath path+  metadata <- parseMetadata osPath >>= either (assertFailure . show) return+  assertEqual "artist is first value" (Just "One") (artist metadata)+  assertEqual "all values in rawTags" (Just ["One", "Two"]) (HM.lookup "ARTIST" (rawTags metadata))+  assertEqual "title" (Just "Multi") (title metadata)++  -- An unrelated update keeps the whole list+  runExceptT (updateMetadata osPath (setTitle "Changed" emptyUpdate))+    >>= either (assertFailure . show) return+  afterTitle <- parseMetadata osPath >>= either (assertFailure . show) return+  assertEqual "artists survive unrelated update"+    (Just ["One", "Two"]) (HM.lookup "ARTIST" (rawTags afterTitle))++  -- Editing the artist replaces the whole list+  runExceptT (updateMetadata osPath (setArtist "Solo" emptyUpdate))+    >>= either (assertFailure . show) return+  afterArtist <- parseMetadata osPath >>= either (assertFailure . show) return+  assertEqual "edit replaces the list" (Just ["Solo"]) (HM.lookup "ARTIST" (rawTags afterArtist))+  removeFile path+  where+    w32le :: Int -> BS.ByteString+    w32le n = BS.pack [fromIntegral (n `shiftR` s) | s <- [0, 8, 16, 24]]++-- | Null-separated ID3v2.4 text frame values are kept as lists (they were+-- previously mashed into one string), survive an unrelated update as one+-- null-separated frame, and are replaced when the field is edited+testMultiValueID3 :: TestTree+testMultiValueID3 = testCase "Multi-valued ID3 text frames are kept as lists" $ do+  let tpe1 = frame24 "TPE1" (BS.singleton 3 <> "One\0Two")  -- UTF-8, two artists+      tit2 = frame24 "TIT2" (BS.singleton 3 <> "Multi")+  path <- writeMalformed "monatone-multi.mp3" (id3v24Tag [tpe1, tit2])+  osPath <- toOsPath path++  metadata <- parseMetadata osPath >>= either (assertFailure . show) return+  assertEqual "artist is first value" (Just "One") (artist metadata)+  assertEqual "all values in rawTags" (Just ["One", "Two"]) (HM.lookup "TPE1" (rawTags metadata))++  -- An unrelated update keeps the whole list+  runExceptT (updateMetadata osPath (setTitle "Changed" emptyUpdate))+    >>= either (assertFailure . show) return+  afterTitle <- parseMetadata osPath >>= either (assertFailure . show) return+  assertEqual "artists survive unrelated update"+    (Just ["One", "Two"]) (HM.lookup "TPE1" (rawTags afterTitle))++  -- Editing the artist replaces the whole list+  runExceptT (updateMetadata osPath (setArtist "Solo" emptyUpdate))+    >>= either (assertFailure . show) return+  afterArtist <- parseMetadata osPath >>= either (assertFailure . show) return+  assertEqual "edit replaces the list" (Just ["Solo"]) (HM.lookup "TPE1" (rawTags afterArtist))+  removeFile path++-- | ALAC audio properties come from the alac extension box, not the+-- AudioSampleEntry header, which typically claims 16-bit/original-rate+-- even for 24-bit files+testAlacProperties :: TestTree+testAlacProperties = testCase "ALAC properties read from the alac box" $ do+  let alacBox = atomBS "alac" $ BS.concat+        [ w32 0                       -- version/flags+        , w32 4096                    -- frame length+        , BS.pack [0, 24, 0, 0, 0, 2] -- compat, bitDepth=24, pb/mb/kb, channels=2+        , BS.pack [0, 0]              -- max run+        , w32 0                       -- max frame bytes+        , w32 0                       -- avg bitrate (unset)+        , w32 96000                   -- sample rate+        ]+      -- AudioSampleEntry header claims 16-bit / 44.1kHz+      entryHeader = BS.concat+        [ BS.replicate 6 0, BS.pack [0, 1]   -- reserved + data ref index+        , BS.replicate 8 0                    -- version/revision/vendor+        , BS.pack [0, 2], BS.pack [0, 16]     -- channels, sample size+        , BS.replicate 4 0                    -- predefined + reserved+        , w32 (44100 * 65536)                 -- sample rate, 16.16 fixed+        ]+      stsd = atomBS "stsd" (w32 0 <> w32 1 <> atomBS "alac" (entryHeader <> alacBox))+      moov = atomBS "moov" $ atomBS "trak" $ atomBS "mdia" $+        atomBS "minf" $ atomBS "stbl" stsd+      bytes = atomBS "ftyp" ("M4A " <> w32 0) <> moov <> atomBS "mdat" ""+  metadata <- parseCrafted "monatone-alac.m4a" bytes+  let props = audioProperties metadata+  assertEqual "codec" (Just CodecALAC) (codec props)+  assertEqual "bit depth from alac box" (Just 24) (bitsPerSample props)+  assertEqual "sample rate from alac box" (Just 96000) (sampleRate props)+  assertEqual "channels" (Just 2) (channels props)++-- | UFID frames carry the MusicBrainz recording id (Picard convention);+-- they were previously misparsed as text frames+testUFIDFrame :: TestTree+testUFIDFrame = testCase "UFID frame yields the MusicBrainz recording id" $ do+  let ufid = frame24 "UFID" ("http://musicbrainz.org" <> BS.singleton 0 <> "b1a9c0e9-d987-4042-ae91-78d6a3267d69")+  metadata <- parseCrafted "monatone-ufid.mp3" (id3v24Tag [ufid])+  assertEqual "recording id"+    (Just "b1a9c0e9-d987-4042-ae91-78d6a3267d69")+    (mbRecordingId (musicBrainzIds metadata))++-- | An existing ID3v1 tag must be rewritten on update, or v1-only readers+-- keep seeing the old fields+testID3v1Refresh :: TestTree+testID3v1Refresh = testCase "ID3v1 tag is refreshed on update" $ do+  let v1Field n t = BS.take n (t <> BS.replicate n 0)+      v1Tag = "TAG" <> v1Field 30 "Old Title" <> v1Field 30 "Artist"+        <> v1Field 30 "Album" <> v1Field 4 "2001" <> v1Field 30 "Comment"+        <> BS.singleton 0xFF+      tit2 = frame24 "TIT2" (BS.singleton 3 <> "Old Title")+  path <- writeMalformed "monatone-v1-refresh.mp3" (id3v24Tag [tit2] <> BS.replicate 32 0 <> v1Tag)+  osPath <- toOsPath path+  runExceptT (updateMetadata osPath (setTitle "New Title" emptyUpdate))+    >>= either (assertFailure . show) return+  final <- BS.readFile path+  removeFile path+  let v1 = BS.drop (BS.length final - 128) final+  assertEqual "v1 tag still present" "TAG" (BS.take 3 v1)+  assertEqual "v1 title updated"+    (v1Field 30 "New Title") (BS.take 30 (BS.drop 3 v1))+  where+    v1Field n t = BS.take n (t <> BS.replicate n 0)++-- | ID3v2.3 "(nn)" and ID3v2.4 bare numeric genres resolve to names+testNumericGenres :: TestTree+testNumericGenres = testCase "Numeric genre references resolve to names" $ do+  refMeta <- parseCrafted "monatone-genre-ref.mp3" $+    id3v24Tag [frame24 "TCON" (BS.singleton 3 <> "(17)")]+  assertEqual "(17) resolves" (Just "Rock") (genre refMeta)++  bareMeta <- parseCrafted "monatone-genre-bare.mp3" $+    id3v24Tag [frame24 "TCON" (BS.singleton 3 <> "17")]+  assertEqual "bare 17 resolves" (Just "Rock") (genre bareMeta)++  refinedMeta <- parseCrafted "monatone-genre-refined.mp3" $+    id3v24Tag [frame24 "TCON" (BS.singleton 3 <> "(17)Post-Rock")]+  assertEqual "refinement wins" (Just "Post-Rock") (genre refinedMeta)++-- | Mixed-case extensions like .Mp3 must be accepted for updates+testMixedCaseExtension :: TestTree+testMixedCaseExtension = testCase "Mixed-case extension is accepted for updates" $ do+  tmpDir <- getTemporaryDirectory+  let origPath = fixturesDir </> "minimal.mp3"+      tmpPath = tmpDir </> "monatone-mixed-case.Mp3"+  origExists <- doesFileExist origPath+  unless origExists $ assertFailure "Test skipped: fixture not available (run with ffmpeg to generate)"+  copyFile origPath tmpPath+  osTmpPath <- toOsPath tmpPath+  result <- runExceptT $ updateMetadata osTmpPath (setTitle "Mixed Case" emptyUpdate)+  removeFile tmpPath+  case result of+    Left err -> assertFailure $ "Update failed: " ++ show err+    Right () -> return ()++-- | Write crafted bytes to a temp file and parse them+parseCrafted :: FilePath -> BS.ByteString -> IO Metadata+parseCrafted fileName bytes = do+  path <- writeMalformed fileName bytes+  osPath <- toOsPath path+  result <- parseMetadata osPath+  removeFile path+  either (assertFailure . show) return result++-- ID3v2 tag builders for crafted test files+id3v24Tag :: [BS.ByteString] -> BS.ByteString+id3v24Tag frames =+  let body = BS.concat frames+  in "ID3" <> BS.pack [4, 0, 0] <> syncsafe32 (BS.length body) <> body++frame24 :: BS.ByteString -> BS.ByteString -> BS.ByteString+frame24 frameId content =+  frameId <> syncsafe32 (BS.length content) <> BS.pack [0, 0] <> content++frame23 :: BS.ByteString -> BS.ByteString -> BS.ByteString+frame23 frameId content =+  frameId <> w32 (BS.length content) <> BS.pack [0, 0] <> content++syncsafe32 :: Int -> BS.ByteString+syncsafe32 n = BS.pack [fromIntegral (n `shiftR` s) .&. 0x7F | s <- [21, 14, 7, 0]]++-- Minimal byte builders for crafting malformed files+atomBS :: BS.ByteString -> BS.ByteString -> BS.ByteString+atomBS name content = w32 (8 + BS.length content) <> name <> content++w32 :: Int -> BS.ByteString+w32 n = BS.pack [fromIntegral (n `shiftR` s) | s <- [24, 16, 8, 0]]++w64 :: Int -> BS.ByteString+w64 n = BS.pack [fromIntegral (n `shiftR` s) | s <- [56, 48, 40, 32, 24, 16, 8, 0]]+ -- | 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@@ -88,9 +529,9 @@           , totalDiscs = Just 2           , releaseStatus = Just "official"           , releaseType = Just "album"-          , rawTags = foldr (uncurry HM.insert) (rawTags parsed) customTags+          , rawTags = foldr (\(k, v) -> HM.insert k [v]) (rawTags parsed) customTags           }-    runExceptT (writeMetadata enriched Nothing osTmpPath)+    runExceptT (writeMetadata enriched KeepExistingArt osTmpPath)       >>= either (assertFailure . show) return      -- The regression under test: an unrelated update must keep all of it@@ -115,7 +556,7 @@     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)))+      assertEqual ("custom tag " ++ T.unpack key) (Just [value]) (HM.lookup key (rawTags final)))       customTags     removeFile tmpPath @@ -146,22 +587,6 @@   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.@@ -179,7 +604,7 @@   -- 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+  result <- runExceptT $ writeMetadata (emptyMetadata M4A) KeepExistingArt osTmpPath   case result of     Left _ -> return ()     Right () -> assertFailure "Expected write to fail on mismatched format"

@@ -93,7 +93,7 @@        osTmpPath <- encodeFS tmpPath       let meta = (emptyMetadata M4A) { title = Just "A considerably longer replacement title" }-      result <- runExceptT $ writeM4AMetadata meta Nothing osTmpPath+      result <- runExceptT $ writeM4AMetadata meta KeepExistingArt osTmpPath       case result of         Left err -> assertFailure $ "Write failed: " ++ show err         Right () -> return ()

@@ -0,0 +1,319 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.OGGSpec (tests) where++import Test.Tasty+import Test.Tasty.HUnit+import Control.Monad.Except (runExceptT)+import Data.Bits (shiftL, shiftR, testBit, xor)+import qualified Data.ByteString as BS+import Data.Word (Word32)+import qualified Data.ByteString.Base64 as B64+import qualified Data.HashMap.Strict as HM+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import System.Directory (getTemporaryDirectory, removeFile)+import System.FilePath ((</>))+import System.OsPath (encodeFS)++import Monatone.Metadata+import Monatone.OGG (parseOGG, loadAlbumArtOGG)+import Monatone.Writer (updateMetadata, setTitle, emptyUpdate)++tests :: TestTree+tests = testGroup "OGG Parser"+  [ testCase "parses comment packet spanning multiple pages" testSpanningComment+  , testCase "parses Opus tags" testOpusTags+  , testCase "loads album art with base64 padding from spanning packet" testSpanningAlbumArt+  , testCase "computes Vorbis duration from the last granule" testVorbisDuration+  , testCase "computes Opus duration accounting for pre-skip" testOpusDuration+  , testCase "updates Vorbis tags in place" testVorbisWrite+  , testCase "updates Opus tags in place" testOpusWrite+  ]++-- | A comment packet larger than one page (> 64KB) must be reassembled+-- from its continuation pages, not parsed per-page+testSpanningComment :: IO ()+testSpanningComment = do+  let bigValue = T.replicate 100000 "x"  -- forces the packet across pages+      commentPacket = vorbisCommentPacket+        [ ("TITLE", "Spanning Title")+        , ("BIGTAG", bigValue)+        , ("ARTIST", "Spanning Artist")+        ]+  metadata <- parseSynthetic "monatone-test-span.ogg" [vorbisIdentPacket, commentPacket]+  assertEqual "title" (Just "Spanning Title") (title metadata)+  assertEqual "artist" (Just "Spanning Artist") (artist metadata)+  assertEqual "big tag survives reassembly" (Just [bigValue]) (HM.lookup "BIGTAG" (rawTags metadata))+  assertEqual "sample rate" (Just 44100) (sampleRate (audioProperties metadata))++-- | OpusTags packets were previously never matched at all+testOpusTags :: IO ()+testOpusTags = do+  let commentPacket = opusTagsPacket [("TITLE", "Opus Title"), ("ARTIST", "Opus Artist")]+  metadata <- parseSynthetic "monatone-test-opus.ogg" [opusIdentPacket, commentPacket]+  assertEqual "codec" (Just CodecOpus) (codec (audioProperties metadata))+  assertEqual "title" (Just "Opus Title") (title metadata)+  assertEqual "artist" (Just "Opus Artist") (artist metadata)+  -- Opus always decodes at 48kHz regardless of the header's input rate+  assertEqual "sample rate" (Just 48000) (sampleRate (audioProperties metadata))++-- | Album art forces both a spanning packet and base64 '=' padding+testSpanningAlbumArt :: IO ()+testSpanningAlbumArt = do+  let imageData = BS.replicate 80000 0xAB  -- forces the packet across pages+      pictureBlock = flacPictureBlock "image/png" imageData+      encoded = TE.decodeUtf8 (B64.encode pictureBlock)+      commentPacket = vorbisCommentPacket+        [ ("TITLE", "Art Test")+        , ("METADATA_BLOCK_PICTURE", encoded)+        ]+  path <- writeSynthetic "monatone-test-art.ogg" [vorbisIdentPacket, commentPacket]+  osPath <- encodeFS path+  -- The encoded block ends in '=' padding; the value must not be truncated+  assertBool "test data has base64 padding" ("=" `T.isSuffixOf` encoded)+  result <- runExceptT $ loadAlbumArtOGG osPath+  removeFile path+  case result of+    Left err -> assertFailure $ "loadAlbumArtOGG failed: " ++ show err+    Right Nothing -> assertFailure "Expected album art, got Nothing"+    Right (Just art) -> do+      assertEqual "mime type" "image/png" (albumArtMimeType art)+      assertEqual "image data" imageData (albumArtData art)++-- | Duration comes from the granule of the file's last page+testVorbisDuration :: IO ()+testVorbisDuration = do+  let bytes = mkOggFile [vorbisIdentPacket, vorbisCommentPacket [("TITLE", "T")]]+        <> lastPage 441000  -- 10s at 44100Hz+  metadata <- parseSyntheticBytes "monatone-dur.ogg" bytes+  assertEqual "duration" (Just 10000) (duration (audioProperties metadata))++-- | Opus granules run at 48kHz and include the pre-skip+testOpusDuration :: IO ()+testOpusDuration = do+  let bytes = mkOggFile [opusIdentPacket, opusTagsPacket [("TITLE", "T")]]+        <> lastPage (480000 + 312)  -- 10s at 48kHz + the header's 312 pre-skip+  metadata <- parseSyntheticBytes "monatone-dur.opus.ogg" bytes+  assertEqual "duration" (Just 10000) (duration (audioProperties metadata))++-- | Updating tags rewrites the comment packet, keeps the setup packet and+-- audio pages, and leaves every page with a valid CRC+testVorbisWrite :: IO ()+testVorbisWrite = do+  let commentPacket = vorbisCommentPacket [("ARTIST", "Keep Me"), ("TITLE", "Old")]+      setupPacket = "\x05vorbis" <> BS.replicate 24 0xAB+      audioPacket = "AUDIOPACKETDATA" <> BS.replicate 300 0x77+      bytes = mkOggPageGroups [[vorbisIdentPacket], [commentPacket, setupPacket], [audioPacket]]+  path <- writeSyntheticBytes "monatone-write.ogg" bytes+  osPath <- encodeFS path++  runExceptT (updateMetadata osPath (setTitle "New Title" emptyUpdate))+    >>= either (assertFailure . show) return++  metadata <- runExceptT (parseOGG osPath) >>= either (assertFailure . show) return+  final <- BS.readFile path+  removeFile path+  assertEqual "title updated" (Just "New Title") (title metadata)+  assertEqual "artist kept" (Just "Keep Me") (artist metadata)+  assertBool "audio kept" ("AUDIOPACKETDATA" `BS.isInfixOf` final)+  assertBool "setup packet kept" (BS.replicate 24 0xAB `BS.isInfixOf` final)+  assertBool "all page CRCs valid" (validOggCrcs final)++testOpusWrite :: IO ()+testOpusWrite = do+  let audioPacket = "OPUSAUDIODATA" <> BS.replicate 100 0x55+      bytes = mkOggPageGroups+        [ [opusIdentPacket]+        , [opusTagsPacket [("ARTIST", "Keep Me"), ("TITLE", "Old")]]+        , [audioPacket]+        ]+  path <- writeSyntheticBytes "monatone-write-opus.ogg" bytes+  osPath <- encodeFS path++  runExceptT (updateMetadata osPath (setTitle "Opus New" emptyUpdate))+    >>= either (assertFailure . show) return++  metadata <- runExceptT (parseOGG osPath) >>= either (assertFailure . show) return+  final <- BS.readFile path+  removeFile path+  assertEqual "title updated" (Just "Opus New") (title metadata)+  assertEqual "artist kept" (Just "Keep Me") (artist metadata)+  assertEqual "codec" (Just CodecOpus) (codec (audioProperties metadata))+  assertBool "audio kept" ("OPUSAUDIODATA" `BS.isInfixOf` final)+  assertBool "all page CRCs valid" (validOggCrcs final)++-- Helpers++parseSynthetic :: FilePath -> [BS.ByteString] -> IO Metadata+parseSynthetic name packets = parseSyntheticBytes name (mkOggFile packets)++parseSyntheticBytes :: FilePath -> BS.ByteString -> IO Metadata+parseSyntheticBytes name bytes = do+  path <- writeSyntheticBytes name bytes+  osPath <- encodeFS path+  result <- runExceptT $ parseOGG osPath+  removeFile path+  either (assertFailure . show) return result++writeSynthetic :: FilePath -> [BS.ByteString] -> IO FilePath+writeSynthetic name packets = writeSyntheticBytes name (mkOggFile packets)++writeSyntheticBytes :: FilePath -> BS.ByteString -> IO FilePath+writeSyntheticBytes name bytes = do+  tmpDir <- getTemporaryDirectory+  let path = tmpDir </> name+  BS.writeFile path bytes+  return path++-- | A final page with the given granule position (EOS, one small segment)+lastPage :: Int -> BS.ByteString+lastPage granule = BS.concat+  [ "OggS"+  , BS.singleton 0            -- version+  , BS.singleton 0x04         -- EOS+  , w64le granule+  , BS.replicate 4 0          -- serial+  , BS.replicate 4 0          -- page sequence+  , BS.replicate 4 0          -- CRC (not verified by the parser)+  , BS.singleton 1+  , BS.singleton 10+  , BS.replicate 10 0x33+  ]++-- | Verify the OGG CRC of every page in the stream+validOggCrcs :: BS.ByteString -> Bool+validOggCrcs = go+  where+    go bs+      | BS.null bs = True+      | BS.length bs < 27 || BS.take 4 bs /= "OggS" = False+      | otherwise =+          let numSegments = fromIntegral $ BS.index bs 26+              lacings = map fromIntegral $ BS.unpack $ BS.take numSegments $ BS.drop 27 bs+              pageLen = 27 + numSegments + sum lacings+              page = BS.take pageLen bs+              stored = BS.take 4 $ BS.drop 22 page+              zeroed = BS.take 22 page <> BS.replicate 4 0 <> BS.drop 26 page+          in BS.length page == pageLen+             && stored == w32le' (fromIntegral (oggCrc zeroed))+             && go (BS.drop pageLen bs)++    w32le' :: Int -> BS.ByteString+    w32le' n = BS.pack [fromIntegral (n `shiftR` s) | s <- [0, 8, 16, 24]]++    oggCrc :: BS.ByteString -> Word32+    oggCrc = BS.foldl' step 0+      where+        step crc byte = spin (8 :: Int) (crc `xor` (fromIntegral byte `shiftL` 24))+        spin 0 crc = crc+        spin n crc = spin (n - 1) $+          if testBit crc 31 then (crc `shiftL` 1) `xor` 0x04c11db7 else crc `shiftL` 1++-- | Serialize logical packets into an OGG page stream. Packets are split+-- into 255-byte lacing segments; pages hold at most 255 segments, and a+-- page starting mid-packet gets the continuation flag (0x01).+mkOggFile :: [BS.ByteString] -> BS.ByteString+mkOggFile packets = mkOggPageGroups [packets]++-- | Like mkOggFile, but each group of packets starts on a fresh page -+-- the spec-conformant layout the writer expects:+-- [[ident], [comment, setup], [audio]]+mkOggPageGroups :: [[BS.ByteString]] -> BS.ByteString+mkOggPageGroups groups = BS.concat (concatMap renderGroup groups)+  where+    renderGroup packets =+      renderPages False (chunksOf 255 (concatMap packetSegments packets))++    -- Segments of one packet: all 255 bytes except the final short one.+    -- A packet whose length is a multiple of 255 ends with an empty segment.+    packetSegments packet =+      let (chunk, rest) = BS.splitAt 255 packet+      in if BS.length chunk == 255+           then chunk : packetSegments rest+           else [chunk]++    chunksOf _ [] = []+    chunksOf n xs = let (h, t) = splitAt n xs in h : chunksOf n t++    renderPages _ [] = []+    renderPages continued (pageSegments : rest) =+      let nextContinued = case reverse pageSegments of+            (lastSegment:_) -> BS.length lastSegment == 255+            [] -> False+      in renderPage continued pageSegments : renderPages nextContinued rest++    renderPage continued pageSegments = BS.concat+      [ "OggS"+      , BS.singleton 0                                   -- version+      , BS.singleton (if continued then 0x01 else 0x00)  -- header type flags+      , BS.replicate 8 0                                 -- granule position+      , BS.replicate 4 0                                 -- serial number+      , BS.replicate 4 0                                 -- page sequence+      , BS.replicate 4 0                                 -- CRC (not verified)+      , BS.singleton (fromIntegral (length pageSegments))+      , BS.pack (map (fromIntegral . BS.length) pageSegments)+      , BS.concat pageSegments+      ]++vorbisIdentPacket :: BS.ByteString+vorbisIdentPacket = BS.concat+  [ "\x01vorbis"+  , w32le 0                 -- vorbis version+  , BS.singleton 2          -- channels+  , w32le 44100             -- sample rate+  , w32le 0                 -- bitrate maximum+  , w32le 128000            -- bitrate nominal+  , w32le 0                 -- bitrate minimum+  , BS.singleton 0xB8       -- blocksizes+  , BS.singleton 0x01       -- framing bit+  ]++opusIdentPacket :: BS.ByteString+opusIdentPacket = BS.concat+  [ "OpusHead"+  , BS.singleton 1          -- version+  , BS.singleton 2          -- channels+  , BS.pack [0x38, 0x01]    -- pre-skip+  , w32le 44100             -- input sample rate (not the decode rate)+  , BS.pack [0, 0]          -- output gain+  , BS.singleton 0          -- mapping family+  ]++vorbisCommentPacket :: [(Text, Text)] -> BS.ByteString+vorbisCommentPacket comments =+  "\x03vorbis" <> commentBody comments <> BS.singleton 0x01  -- framing bit++opusTagsPacket :: [(Text, Text)] -> BS.ByteString+opusTagsPacket comments = "OpusTags" <> commentBody comments++commentBody :: [(Text, Text)] -> BS.ByteString+commentBody comments = BS.concat $+  [ w32le 0                                    -- vendor string length+  , w32le (fromIntegral (length comments))+  ] ++ map renderComment comments+  where+    renderComment (key, value) =+      let bytes = TE.encodeUtf8 (key <> "=" <> value)+      in w32le (fromIntegral (BS.length bytes)) <> bytes++flacPictureBlock :: BS.ByteString -> BS.ByteString -> BS.ByteString+flacPictureBlock mimeType imageData = BS.concat+  [ w32be 3                                    -- picture type: front cover+  , w32be (fromIntegral (BS.length mimeType))+  , mimeType+  , w32be 0                                    -- description length+  , w32be 0, w32be 0, w32be 0, w32be 0         -- width/height/depth/colors+  , w32be (fromIntegral (BS.length imageData))+  , imageData+  ]++w32le :: Int -> BS.ByteString+w32le n = BS.pack [fromIntegral (n `div` (256 ^ i)) | i <- [0 :: Int, 1, 2, 3]]++w64le :: Int -> BS.ByteString+w64le n = BS.pack [fromIntegral (n `div` (256 ^ i)) | i <- [0 :: Int .. 7]]++w32be :: Int -> BS.ByteString+w32be n = BS.pack [fromIntegral (n `div` (256 ^ i)) | i <- [3, 2, 1, 0 :: Int]]