diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/monatone.cabal b/monatone.cabal --- a/monatone.cabal +++ b/monatone.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: monatone -version: 0.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, diff --git a/src/Monatone/FLAC.hs b/src/Monatone/FLAC.hs --- a/src/Monatone/FLAC.hs +++ b/src/Monatone/FLAC.hs @@ -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) diff --git a/src/Monatone/FLAC/Writer.hs b/src/Monatone/FLAC/Writer.hs --- a/src/Monatone/FLAC/Writer.hs +++ b/src/Monatone/FLAC/Writer.hs @@ -1,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 diff --git a/src/Monatone/M4A.hs b/src/Monatone/M4A.hs --- a/src/Monatone/M4A.hs +++ b/src/Monatone/M4A.hs @@ -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 diff --git a/src/Monatone/M4A/Writer.hs b/src/Monatone/M4A/Writer.hs --- a/src/Monatone/M4A/Writer.hs +++ b/src/Monatone/M4A/Writer.hs @@ -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 diff --git a/src/Monatone/MP3.hs b/src/Monatone/MP3.hs --- a/src/Monatone/MP3.hs +++ b/src/Monatone/MP3.hs @@ -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 diff --git a/src/Monatone/MP3/Writer.hs b/src/Monatone/MP3/Writer.hs --- a/src/Monatone/MP3/Writer.hs +++ b/src/Monatone/MP3/Writer.hs @@ -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 diff --git a/src/Monatone/Metadata.hs b/src/Monatone/Metadata.hs --- a/src/Monatone/Metadata.hs +++ b/src/Monatone/Metadata.hs @@ -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 diff --git a/src/Monatone/OGG.hs b/src/Monatone/OGG.hs --- a/src/Monatone/OGG.hs +++ b/src/Monatone/OGG.hs @@ -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) diff --git a/src/Monatone/OGG/Writer.hs b/src/Monatone/OGG/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Monatone/OGG/Writer.hs @@ -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]] diff --git a/src/Monatone/Writer.hs b/src/Monatone/Writer.hs --- a/src/Monatone/Writer.hs +++ b/src/Monatone/Writer.hs @@ -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 + diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/test/Test/IntegrationSpec.hs b/test/Test/IntegrationSpec.hs --- a/test/Test/IntegrationSpec.hs +++ b/test/Test/IntegrationSpec.hs @@ -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" diff --git a/test/Test/M4ASpec.hs b/test/Test/M4ASpec.hs --- a/test/Test/M4ASpec.hs +++ b/test/Test/M4ASpec.hs @@ -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 () diff --git a/test/Test/OGGSpec.hs b/test/Test/OGGSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/OGGSpec.hs @@ -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]]