monatone-0.4.0.0: test/Test/IntegrationSpec.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE QuasiQuotes #-}
module Test.IntegrationSpec (tests) where
import Test.Tasty
import Test.Tasty.HUnit
import Control.Monad.Except (runExceptT)
import System.FilePath ((</>))
import System.Directory (doesFileExist, copyFile, removeFile, getTemporaryDirectory)
import System.Process (callProcess)
import Control.Exception (catch, evaluate, SomeException)
import Control.Monad (unless)
import System.OsPath hiding ((</>))
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)
import Monatone.Metadata
import Monatone.Writer
tests :: TestTree
tests = withResource ensureFixtures (const $ return ()) $ \_ ->
testGroup "Integration Tests"
[ testGroup "Reading Real Files"
[ testReadMinimalMP3
, testReadTaggedMP3
, testReadMinimalFLAC
, testReadMinimalM4A
]
, testGroup "Round-trip Tests"
[ testMP3RoundTrip
, testFLACRoundTrip
, testM4ARoundTrip
]
, 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")]
, testTagPreservation "FLAC" "minimal.flac"
[("MYCUSTOMTAG", "custom-value")]
, testTagPreservation "M4A" "minimal.m4a"
[("----:com.example.test:CustomField", "custom-value"), ("\169wrt", "A Composer")]
, testFLACBlockPreservation
]
]
-- | 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
testTagPreservation label fixtureName customTags =
testCase (label ++ " update preserves unrelated tags") $ do
tmpDir <- getTemporaryDirectory
let origPath = fixturesDir </> fixtureName
tmpPath = tmpDir </> "monatone-test-preserve-" ++ fixtureName
origExists <- doesFileExist origPath
unless origExists $ assertFailure "Test skipped: fixture not available (run with ffmpeg to generate)"
copyFile origPath tmpPath
osTmpPath <- toOsPath tmpPath
-- Enrich the file with everything an update must not lose
parsed <- parseMetadata osTmpPath >>= either (assertFailure . show) return
let enriched = parsed
{ musicBrainzIds = MusicBrainzIds
{ mbTrackId = Just "mb-track"
, mbRecordingId = Just "mb-recording"
, mbReleaseId = Just "mb-release"
, mbReleaseGroupId = Just "mb-release-group"
, mbArtistId = Just "mb-artist"
, mbAlbumArtistId = Just "mb-album-artist"
, mbWorkId = Just "mb-work"
, mbDiscId = Just "mb-disc"
}
, acoustidFingerprint = Just "fp-12345"
, acoustidId = Just "acoustid-67890"
-- MP3/M4A can only carry totals alongside a number ("n/total"),
-- so the numbers must be present too
, trackNumber = Just 7
, totalTracks = Just 12
, discNumber = Just 1
, totalDiscs = Just 2
, releaseStatus = Just "official"
, releaseType = Just "album"
, rawTags = foldr (\(k, v) -> HM.insert k [v]) (rawTags parsed) customTags
}
runExceptT (writeMetadata enriched KeepExistingArt osTmpPath)
>>= either (assertFailure . show) return
-- The regression under test: an unrelated update must keep all of it
runExceptT (updateMetadata osTmpPath (setTitle "Preserved Title Test" emptyUpdate))
>>= either (assertFailure . show) return
final <- parseMetadata osTmpPath >>= either (assertFailure . show) return
assertEqual "title updated" (Just "Preserved Title Test") (title final)
let mbIds = musicBrainzIds final
assertEqual "mbTrackId" (Just "mb-track") (mbTrackId mbIds)
assertEqual "mbRecordingId" (Just "mb-recording") (mbRecordingId mbIds)
assertEqual "mbReleaseId" (Just "mb-release") (mbReleaseId mbIds)
assertEqual "mbReleaseGroupId" (Just "mb-release-group") (mbReleaseGroupId mbIds)
assertEqual "mbArtistId" (Just "mb-artist") (mbArtistId mbIds)
assertEqual "mbAlbumArtistId" (Just "mb-album-artist") (mbAlbumArtistId mbIds)
assertEqual "mbWorkId" (Just "mb-work") (mbWorkId mbIds)
assertEqual "mbDiscId" (Just "mb-disc") (mbDiscId mbIds)
assertEqual "acoustidFingerprint" (Just "fp-12345") (acoustidFingerprint final)
assertEqual "acoustidId" (Just "acoustid-67890") (acoustidId final)
assertEqual "totalTracks" (Just 12) (totalTracks final)
assertEqual "totalDiscs" (Just 2) (totalDiscs final)
assertEqual "releaseStatus" (Just "official") (releaseStatus final)
assertEqual "releaseType" (Just "album") (releaseType final)
mapM_ (\(key, value) ->
assertEqual ("custom tag " ++ T.unpack key) (Just [value]) (HM.lookup key (rawTags final)))
customTags
removeFile tmpPath
-- | FLAC updates must carry over metadata blocks they do not regenerate
-- (SEEKTABLE, APPLICATION, CUESHEET)
testFLACBlockPreservation :: TestTree
testFLACBlockPreservation = testCase "FLAC update preserves SEEKTABLE block" $ do
tmpDir <- getTemporaryDirectory
let origPath = fixturesDir </> "minimal.flac"
tmpPath = tmpDir </> "monatone-test-seektable.flac"
origExists <- doesFileExist origPath
unless origExists $ assertFailure "Test skipped: fixture not available (run with ffmpeg to generate)"
-- Insert a synthetic SEEKTABLE (type 3, one placeholder seekpoint) after
-- STREAMINFO: 4-byte signature + 38-byte STREAMINFO block, then the rest
orig <- BS.readFile origPath
let (prefix, rest) = BS.splitAt 42 orig
seekPoint = BS.replicate 18 0xFF -- placeholder seekpoint per spec
seekTable = BS.pack [3, 0, 0, 18] <> seekPoint
BS.writeFile tmpPath (prefix <> seekTable <> rest)
osTmpPath <- toOsPath tmpPath
runExceptT (updateMetadata osTmpPath (setTitle "Block Preservation" emptyUpdate))
>>= either (assertFailure . show) return
final <- BS.readFile tmpPath
let blocks = flacBlocks final
assertBool "SEEKTABLE block survived the update" $
(3, seekTable) `elem` [(t, BS.pack [3, 0, 0, 18] <> c) | (t, c) <- blocks, t == 3]
removeFile tmpPath
-- | Writes go through a temp copy + atomic rename, so a failed write must
-- leave the original file byte-identical and clean up its temp file.
testFailedWriteLeavesOriginalIntact :: TestTree
testFailedWriteLeavesOriginalIntact = testCase "Failed write leaves original untouched" $ do
tmpDir <- getTemporaryDirectory
let origPath = fixturesDir </> "minimal.flac"
tmpPath = tmpDir </> "monatone-test-atomic.flac"
origExists <- doesFileExist origPath
unless origExists $ assertFailure "Test skipped: fixture not available (run with ffmpeg to generate)"
copyFile origPath tmpPath
before <- BS.readFile tmpPath
-- Force a failure: metadata claims M4A, but the file is FLAC, so the
-- M4A writer errors out partway through
osTmpPath <- toOsPath tmpPath
result <- runExceptT $ writeMetadata (emptyMetadata M4A) KeepExistingArt osTmpPath
case result of
Left _ -> return ()
Right () -> assertFailure "Expected write to fail on mismatched format"
after <- BS.readFile tmpPath
assertEqual "original bytes unchanged after failed write" before after
leftover <- doesFileExist (tmpPath ++ ".monatone.tmp")
assertBool "no temp file left behind" (not leftover)
removeFile tmpPath
-- | Ensure test fixtures exist, generate them if missing
ensureFixtures :: IO ()
ensureFixtures = do
let files = [ fixturesDir </> "minimal.mp3"
, fixturesDir </> "tagged.mp3"
, fixturesDir </> "minimal.flac"
, fixturesDir </> "minimal.m4a"
]
allExist <- and <$> mapM doesFileExist files
unless allExist $ do
putStrLn "Test fixtures not found. Attempting to generate with ffmpeg..."
generateTestFiles `catch` handleError
where
handleError :: SomeException -> IO ()
handleError _ = putStrLn "Warning: Could not generate test fixtures (ffmpeg not available). Integration tests will be skipped."
-- | Generate test files using ffmpeg
generateTestFiles :: IO ()
generateTestFiles = do
-- Generate 1 second of silence as raw PCM
callProcess "ffmpeg" ["-f", "lavfi", "-i", "anullsrc=r=44100:cl=stereo",
"-t", "1", "-f", "s16le", "-y", "/tmp/silence.raw"]
-- Create MP3 with metadata
callProcess "ffmpeg" ["-f", "s16le", "-ar", "44100", "-ac", "2", "-i", "/tmp/silence.raw",
"-codec:a", "libmp3lame", "-b:a", "128k",
"-metadata", "title=Test Title",
"-metadata", "artist=Test Artist",
"-metadata", "album=Test Album",
"-metadata", "date=2024",
"-metadata", "track=1/10",
"-metadata", "genre=Rock",
"-metadata", "comment=Test comment",
"-y", fixturesDir </> "tagged.mp3"]
-- Create minimal MP3
callProcess "ffmpeg" ["-f", "s16le", "-ar", "44100", "-ac", "2", "-i", "/tmp/silence.raw",
"-codec:a", "libmp3lame", "-b:a", "128k",
"-metadata", "title=Minimal Title",
"-y", fixturesDir </> "minimal.mp3"]
-- Create FLAC with metadata
callProcess "ffmpeg" ["-f", "s16le", "-ar", "44100", "-ac", "2", "-i", "/tmp/silence.raw",
"-codec:a", "flac",
"-metadata", "title=FLAC Test Track",
"-metadata", "artist=Test Band",
"-metadata", "album=FLAC Album",
"-metadata", "date=2024",
"-metadata", "track=3",
"-metadata", "comment=FLAC test comment",
"-y", fixturesDir </> "minimal.flac"]
-- Create M4A with metadata (AAC)
callProcess "ffmpeg" ["-f", "s16le", "-ar", "44100", "-ac", "2", "-i", "/tmp/silence.raw",
"-codec:a", "aac", "-b:a", "128k",
"-metadata", "title=M4A Test Track",
"-metadata", "artist=M4A Artist",
"-metadata", "album=M4A Album",
"-metadata", "date=2024",
"-metadata", "track=2/10",
"-metadata", "genre=Electronic",
"-metadata", "comment=M4A test comment",
"-y", fixturesDir </> "minimal.m4a"]
-- Clean up
removeFile "/tmp/silence.raw" `catch` (\(_ :: SomeException) -> return ())
fixturesDir :: FilePath
fixturesDir = "test/fixtures"
-- Helper to convert FilePath to OsPath
toOsPath :: FilePath -> IO OsPath
toOsPath = encodeFS
testReadMinimalMP3 :: TestTree
testReadMinimalMP3 = testCase "Read minimal MP3" $ do
let path = fixturesDir </> "minimal.mp3"
exists <- doesFileExist path
unless exists $ assertFailure "Test skipped: fixture not available (run with ffmpeg to generate)"
osPath <- toOsPath path
result <- parseMetadata osPath
case result of
Left err -> assertFailure $ T.unpack $ "Failed to parse: " <> T.pack (show err)
Right metadata -> do
assertEqual "Format" MP3 (format metadata)
assertEqual "Title" (Just "Minimal Title") (title metadata)
testReadTaggedMP3 :: TestTree
testReadTaggedMP3 = testCase "Read MP3 with full metadata" $ do
let path = fixturesDir </> "tagged.mp3"
exists <- doesFileExist path
assertBool "Test file exists" exists
osPath <- toOsPath path
result <- parseMetadata osPath
case result of
Left err -> assertFailure $ T.unpack $ "Failed to parse: " <> T.pack (show err)
Right metadata -> do
assertEqual "Format" MP3 (format metadata)
assertEqual "Title" (Just "Test Title") (title metadata)
assertEqual "Artist" (Just "Test Artist") (artist metadata)
assertEqual "Album" (Just "Test Album") (album metadata)
assertEqual "Year" (Just 2024) (year metadata)
assertEqual "Track number" (Just 1) (trackNumber metadata)
assertEqual "Genre" (Just "Rock") (genre metadata)
assertEqual "Comment" (Just "Test comment") (comment metadata)
testReadMinimalFLAC :: TestTree
testReadMinimalFLAC = testCase "Read minimal FLAC" $ do
let path = fixturesDir </> "minimal.flac"
exists <- doesFileExist path
assertBool "Test file exists" exists
osPath <- toOsPath path
result <- parseMetadata osPath
case result of
Left err -> assertFailure $ T.unpack $ "Failed to parse: " <> T.pack (show err)
Right metadata -> do
assertEqual "Format" FLAC (format metadata)
assertEqual "Title" (Just "FLAC Test Track") (title metadata)
assertEqual "Artist" (Just "Test Band") (artist metadata)
-- Check audio properties from STREAMINFO
let props = audioProperties metadata
case sampleRate props of
Just sr -> assertEqual "Sample rate" 44100 sr
Nothing -> assertFailure "No sample rate found"
case channels props of
Just ch -> assertEqual "Channels" 2 ch
Nothing -> assertFailure "No channels found"
testMP3RoundTrip :: TestTree
testMP3RoundTrip = testCase "MP3 read-write-read round trip" $ do
-- Use system temp directory
tmpDir <- getTemporaryDirectory
let origPath = fixturesDir </> "tagged.mp3"
let tmpPath = tmpDir </> "monatone-test-mp3.mp3"
-- Verify source file exists
origExists <- doesFileExist origPath
assertBool (T.unpack $ "Source file exists: " <> T.pack origPath) origExists
-- Copy file to temp location
copyFile origPath tmpPath
-- Verify copy succeeded
tmpExists <- doesFileExist tmpPath
assertBool (T.unpack $ "Temp file created: " <> T.pack tmpPath) tmpExists
-- Read original metadata
osTmpPath <- toOsPath tmpPath
origResult <- parseMetadata osTmpPath
origMetadata <- case origResult of
Left err -> assertFailure $ T.unpack $ "Failed to read original: " <> T.pack (show err)
Right m -> return m
-- Modify metadata
let update = setTitle "Modified Title" $
setArtist "Modified Artist" $
setYear 2025 $
emptyUpdate
writeResult <- runExceptT $ updateMetadata osTmpPath update
case writeResult of
Left err -> assertFailure $ "Failed to write: " ++ show err
Right () -> return ()
-- Read modified metadata
modResult <- parseMetadata osTmpPath
case modResult of
Left err -> assertFailure $ "Failed to read modified: " ++ show err
Right modMetadata -> do
assertEqual "Modified title" (Just "Modified Title") (title modMetadata)
assertEqual "Modified artist" (Just "Modified Artist") (artist modMetadata)
assertEqual "Modified year" (Just 2025) (year modMetadata)
-- Unchanged fields should be preserved
assertEqual "Album preserved" (album origMetadata) (album modMetadata)
assertEqual "Genre preserved" (genre origMetadata) (genre modMetadata)
-- Clean up
removeFile tmpPath
testFLACRoundTrip :: TestTree
testFLACRoundTrip = testCase "FLAC read-write-read round trip" $ do
-- Use system temp directory
tmpDir <- getTemporaryDirectory
let origPath = fixturesDir </> "minimal.flac"
let tmpPath = tmpDir </> "monatone-test-flac.flac"
-- Verify source file exists
origExists <- doesFileExist origPath
assertBool (T.unpack $ "Source file exists: " <> T.pack origPath) origExists
-- Copy file to temp location
copyFile origPath tmpPath
-- Verify copy succeeded
tmpExists <- doesFileExist tmpPath
assertBool (T.unpack $ "Temp file created: " <> T.pack tmpPath) tmpExists
-- Read original metadata
osTmpPath <- toOsPath tmpPath
origResult <- parseMetadata osTmpPath
origMetadata <- case origResult of
Left err -> assertFailure $ T.unpack $ "Failed to read original: " <> T.pack (show err)
Right m -> return m
-- Modify metadata
let update = setTitle "New FLAC Title" $
setAlbum "New Album" $
setTrackNumber 5 $
setComment "Test comment" $
emptyUpdate
writeResult <- runExceptT $ updateMetadata osTmpPath update
case writeResult of
Left err -> assertFailure $ "Failed to write: " ++ show err
Right () -> return ()
-- Read modified metadata
modResult <- parseMetadata osTmpPath
case modResult of
Left err -> assertFailure $ "Failed to read modified: " ++ show err
Right modMetadata -> do
assertEqual "Modified title" (Just "New FLAC Title") (title modMetadata)
assertEqual "Modified album" (Just "New Album") (album modMetadata)
assertEqual "Modified track" (Just 5) (trackNumber modMetadata)
assertEqual "Modified comment" (Just "Test comment") (comment modMetadata)
-- Original artist should be preserved
assertEqual "Artist preserved" (artist origMetadata) (artist modMetadata)
-- Audio properties should remain unchanged
assertEqual "Audio props preserved"
(audioProperties origMetadata)
(audioProperties modMetadata)
-- Clean up
removeFile tmpPath
testReadMinimalM4A :: TestTree
testReadMinimalM4A = testCase "Read minimal M4A" $ do
let path = fixturesDir </> "minimal.m4a"
exists <- doesFileExist path
unless exists $ assertFailure "Test skipped: fixture not available (run with ffmpeg to generate)"
osPath <- toOsPath path
result <- parseMetadata osPath
case result of
Left err -> assertFailure $ T.unpack $ "Failed to parse: " <> T.pack (show err)
Right metadata -> do
assertEqual "Format" M4A (format metadata)
assertEqual "Title" (Just "M4A Test Track") (title metadata)
assertEqual "Artist" (Just "M4A Artist") (artist metadata)
assertEqual "Album" (Just "M4A Album") (album metadata)
assertEqual "Track number" (Just 2) (trackNumber metadata)
assertEqual "Total tracks" (Just 10) (totalTracks metadata)
assertEqual "Genre" (Just "Electronic") (genre metadata)
-- Check audio properties
let props = audioProperties metadata
case sampleRate props of
Just sr -> assertEqual "Sample rate" 44100 sr
Nothing -> assertFailure "No sample rate found"
case channels props of
Just ch -> assertEqual "Channels" 2 ch
Nothing -> assertFailure "No channels found"
testM4ARoundTrip :: TestTree
testM4ARoundTrip = testCase "M4A read-write-read round trip" $ do
-- Use system temp directory
tmpDir <- getTemporaryDirectory
let origPath = fixturesDir </> "minimal.m4a"
let tmpPath = tmpDir </> "monatone-test-m4a.m4a"
-- Verify source file exists
origExists <- doesFileExist origPath
unless origExists $ assertFailure "Test skipped: fixture not available (run with ffmpeg to generate)"
-- Copy file to temp location
copyFile origPath tmpPath
-- Verify copy succeeded
tmpExists <- doesFileExist tmpPath
assertBool (T.unpack $ "Temp file created: " <> T.pack tmpPath) tmpExists
-- Read original metadata
osTmpPath <- toOsPath tmpPath
origResult <- parseMetadata osTmpPath
origMetadata <- case origResult of
Left err -> assertFailure $ T.unpack $ "Failed to read original: " <> T.pack (show err)
Right m -> return m
-- Modify metadata including freeform fields
let update = setTitle "Modified M4A Title" $
setArtist "New Artist" $
setYear 2025 $
setTrackNumber 7 $
setGenre "Jazz" $
setLabel "Test Records" $
setCatalogNumber "TEST-001" $
setBarcode "1234567890123" $
setReleaseCountry "US" $
emptyUpdate
writeResult <- runExceptT $ updateMetadata osTmpPath update
case writeResult of
Left err -> assertFailure $ "Failed to write: " ++ show err
Right () -> return ()
-- Read modified metadata
modResult <- parseMetadata osTmpPath
case modResult of
Left err -> assertFailure $ "Failed to read modified: " ++ show err
Right modMetadata -> do
assertEqual "Modified title" (Just "Modified M4A Title") (title modMetadata)
assertEqual "Modified artist" (Just "New Artist") (artist modMetadata)
assertEqual "Modified year" (Just 2025) (year modMetadata)
assertEqual "Modified track" (Just 7) (trackNumber modMetadata)
assertEqual "Modified genre" (Just "Jazz") (genre modMetadata)
-- Freeform fields
assertEqual "Record label" (Just "Test Records") (recordLabel modMetadata)
assertEqual "Catalog number" (Just "TEST-001") (catalogNumber modMetadata)
assertEqual "Barcode" (Just "1234567890123") (barcode modMetadata)
assertEqual "Release country" (Just "US") (releaseCountry modMetadata)
-- Unchanged fields should be preserved
assertEqual "Album preserved" (album origMetadata) (album modMetadata)
assertEqual "Comment preserved" (comment origMetadata) (comment modMetadata)
-- Total tracks should be preserved
assertEqual "Total tracks preserved" (totalTracks origMetadata) (totalTracks modMetadata)
-- Audio properties should remain unchanged
assertEqual "Audio props preserved"
(audioProperties origMetadata)
(audioProperties modMetadata)
-- Clean up
removeFile tmpPath