{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}

module Monatone.M4A
  ( parseM4A
  , loadAlbumArtM4A
  ) where

import Control.Applicative ((<|>))
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Except (throwError)
import Data.Binary.Get
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
import Data.Maybe (listToMaybe)
import Data.Word
import System.IO (Handle, IOMode(..), hSeek, SeekMode(..), hFileSize, hTell)
import System.OsPath
import System.File.OsPath (withBinaryFile)
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 qualified Data.Text.Encoding.Error as TEE

import Monatone.Metadata
import Monatone.Types

-- | MP4 atom structure
data Atom = Atom
  { Atom -> ByteString
atomName :: BS.ByteString
  , Atom -> Word64
atomSize :: Word64
  , Atom -> Integer
atomOffset :: Integer
  , Atom -> Maybe [Atom]
atomChildren :: Maybe [Atom]
  , Atom -> Integer
atomDataOffset :: Integer
  } deriving (Int -> Atom -> ShowS
[Atom] -> ShowS
Atom -> String
(Int -> Atom -> ShowS)
-> (Atom -> String) -> ([Atom] -> ShowS) -> Show Atom
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Atom -> ShowS
showsPrec :: Int -> Atom -> ShowS
$cshow :: Atom -> String
show :: Atom -> String
$cshowList :: [Atom] -> ShowS
showList :: [Atom] -> ShowS
Show, Atom -> Atom -> Bool
(Atom -> Atom -> Bool) -> (Atom -> Atom -> Bool) -> Eq Atom
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Atom -> Atom -> Bool
== :: Atom -> Atom -> Bool
$c/= :: Atom -> Atom -> Bool
/= :: Atom -> Atom -> Bool
Eq)

-- | Container atoms that have children
containerAtoms :: [BS.ByteString]
containerAtoms :: [ByteString]
containerAtoms = [ByteString
"moov", ByteString
"udta", ByteString
"trak", ByteString
"mdia", ByteString
"meta", ByteString
"ilst", ByteString
"stbl", ByteString
"minf", ByteString
"moof", ByteString
"traf", ByteString
"stsd"]

-- | Parse M4A file
parseM4A :: OsPath -> Parser Metadata
parseM4A :: OsPath -> Parser Metadata
parseM4A OsPath
filePath = do
  Either ParseError Metadata
result <- IO (Either ParseError Metadata)
-> ExceptT ParseError IO (Either ParseError Metadata)
forall a. IO a -> ExceptT ParseError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ParseError Metadata)
 -> ExceptT ParseError IO (Either ParseError Metadata))
-> IO (Either ParseError Metadata)
-> ExceptT ParseError IO (Either ParseError Metadata)
forall a b. (a -> b) -> a -> b
$ OsPath
-> IOMode
-> (Handle -> IO (Either ParseError Metadata))
-> IO (Either ParseError Metadata)
forall r. OsPath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile OsPath
filePath IOMode
ReadMode ((Handle -> IO (Either ParseError Metadata))
 -> IO (Either ParseError Metadata))
-> (Handle -> IO (Either ParseError Metadata))
-> IO (Either ParseError Metadata)
forall a b. (a -> b) -> a -> b
$ \Handle
handle -> do
    -- Parse atom structure
    [Atom]
atoms <- Handle -> IO [Atom]
parseAtoms Handle
handle

    -- Extract metadata from ilst atom
    Metadata
metadata <- Handle -> [Atom] -> Metadata -> IO Metadata
extractMetadata Handle
handle [Atom]
atoms (AudioFormat -> Metadata
emptyMetadata AudioFormat
M4A)

    -- Parse audio properties
    AudioProperties
audioProps <- Handle -> [Atom] -> IO AudioProperties
extractAudioProperties Handle
handle [Atom]
atoms

    Either ParseError Metadata -> IO (Either ParseError Metadata)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseError Metadata -> IO (Either ParseError Metadata))
-> Either ParseError Metadata -> IO (Either ParseError Metadata)
forall a b. (a -> b) -> a -> b
$ Metadata -> Either ParseError Metadata
forall a b. b -> Either a b
Right (Metadata -> Either ParseError Metadata)
-> Metadata -> Either ParseError Metadata
forall a b. (a -> b) -> a -> b
$ Metadata
metadata { audioProperties = audioProps }

  case Either ParseError Metadata
result of
    Left ParseError
err -> ParseError -> Parser Metadata
forall a. ParseError -> ExceptT ParseError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ParseError
err
    Right Metadata
m -> Metadata -> Parser Metadata
forall a. a -> ExceptT ParseError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Metadata
m

-- | Parse all top-level atoms
parseAtoms :: Handle -> IO [Atom]
parseAtoms :: Handle -> IO [Atom]
parseAtoms Handle
handle = do
  Integer
fileSize <- Handle -> IO Integer
hFileSize Handle
handle
  Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek Integer
0
  Handle -> Integer -> IO [Atom]
parseAtomsUntil Handle
handle Integer
fileSize

-- | Parse atoms until we reach the end position
parseAtomsUntil :: Handle -> Integer -> IO [Atom]
parseAtomsUntil :: Handle -> Integer -> IO [Atom]
parseAtomsUntil Handle
handle Integer
endPos = do
  Integer
pos <- Handle -> IO Integer
hTell Handle
handle
  -- putStrLn $ "parseAtomsUntil: pos=" ++ show pos ++ ", endPos=" ++ show endPos
  if Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
8 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
endPos
    then [Atom] -> IO [Atom]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    else do
      Maybe Atom
maybeAtom <- Handle -> Int -> IO (Maybe Atom)
parseAtom Handle
handle Int
0
      case Maybe Atom
maybeAtom of
        Maybe Atom
Nothing -> [Atom] -> IO [Atom]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        Just Atom
atom -> do
          -- putStrLn $ "Parsed atom: " ++ show (atomName atom) ++ " at " ++ show (atomOffset atom)
          [Atom]
rest <- Handle -> Integer -> IO [Atom]
parseAtomsUntil Handle
handle Integer
endPos
          [Atom] -> IO [Atom]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Atom
atom Atom -> [Atom] -> [Atom]
forall a. a -> [a] -> [a]
: [Atom]
rest)

-- | Parse a single atom
parseAtom :: Handle -> Int -> IO (Maybe Atom)
parseAtom :: Handle -> Int -> IO (Maybe Atom)
parseAtom Handle
handle Int
_level = do
  Integer
offset <- Handle -> IO Integer
hTell Handle
handle
  ByteString
headerData <- Handle -> Int -> IO ByteString
BS.hGet Handle
handle Int
8

  if ByteString -> Int
BS.length ByteString
headerData Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8
    then Maybe Atom -> IO (Maybe Atom)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Atom
forall a. Maybe a
Nothing
    else do
      let (Word32
size32, ByteString
name) = Get (Word32, ByteString) -> ByteString -> (Word32, ByteString)
forall a. Get a -> ByteString -> a
runGet ((,) (Word32 -> ByteString -> (Word32, ByteString))
-> Get Word32 -> Get (ByteString -> (Word32, ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be Get (ByteString -> (Word32, ByteString))
-> Get ByteString -> Get (Word32, ByteString)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Get ByteString
getByteString Int
4) (ByteString -> ByteString
L.fromStrict ByteString
headerData)

      -- Handle 64-bit size
      (Word64
actualSize, Integer
dataOffset) <- if Word32
size32 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
1
        then do
          ByteString
size64Data <- Handle -> Int -> IO ByteString
BS.hGet Handle
handle Int
8
          let size64 :: Word64
size64 = Get Word64 -> ByteString -> Word64
forall a. Get a -> ByteString -> a
runGet Get Word64
getWord64be (ByteString -> ByteString
L.fromStrict ByteString
size64Data)
          (Word64, Integer) -> IO (Word64, Integer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
size64, Integer
offset Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
16)
        else if Word32
size32 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0
          then do
            -- Size extends to end of file
            Integer
fileSize <- Handle -> IO Integer
hFileSize Handle
handle
            (Word64, Integer) -> IO (Word64, Integer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
fileSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
offset), Integer
offset Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
8)
        else (Word64, Integer) -> IO (Word64, Integer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size32, Integer
offset Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
8)

      -- Check if this is a container atom
      -- Note: We'll determine if we need children during parsing
      let isContainer :: Bool
isContainer = ByteString
name ByteString -> [ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString]
containerAtoms

      [Atom]
children <- if Bool
isContainer
        then do
          -- For meta atom, skip 4 bytes (version/flags)
          let skipBytes :: Integer
              skipBytes :: Integer
skipBytes = if ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"meta" then Integer
4 else Integer
0
          Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek (Integer
dataOffset Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
skipBytes)

          -- Parse children
          let endPos :: Integer
endPos = Integer
offset Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
actualSize
          [Atom]
childList <- Handle -> Integer -> IO [Atom]
parseAtomsUntil Handle
handle Integer
endPos
          -- Debug moov children
          -- when (name == "moov") $ putStrLn $ "moov children: " ++ show (map atomName childList)

          -- IMPORTANT: Seek to end of this atom so next sibling can be parsed
          Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek (Integer
offset Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
actualSize)
          [Atom] -> IO [Atom]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Atom]
childList
        else do
          -- Seek to end of this atom
          Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek (Integer
offset Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
actualSize)
          [Atom] -> IO [Atom]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

      let atom :: Atom
atom = Atom
            { atomName :: ByteString
atomName = ByteString
name
            , atomSize :: Word64
atomSize = Word64
actualSize
            , atomOffset :: Integer
atomOffset = Integer
offset
            , atomChildren :: Maybe [Atom]
atomChildren = if Bool
isContainer then [Atom] -> Maybe [Atom]
forall a. a -> Maybe a
Just [Atom]
children else Maybe [Atom]
forall a. Maybe a
Nothing
            , atomDataOffset :: Integer
atomDataOffset = Integer
dataOffset Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ if ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"meta" then Integer
4 else Integer
0
            }

      Maybe Atom -> IO (Maybe Atom)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Atom -> IO (Maybe Atom)) -> Maybe Atom -> IO (Maybe Atom)
forall a b. (a -> b) -> a -> b
$ Atom -> Maybe Atom
forall a. a -> Maybe a
Just Atom
atom

-- | Find atom by path (e.g., ["moov", "udta", "meta", "ilst"])
findAtomPath :: [Atom] -> [BS.ByteString] -> Maybe Atom
findAtomPath :: [Atom] -> [ByteString] -> Maybe Atom
findAtomPath [Atom]
_ [] = Maybe Atom
forall a. Maybe a
Nothing
findAtomPath [Atom]
atoms [ByteString
name] = [Atom] -> Maybe Atom
forall a. [a] -> Maybe a
listToMaybe ([Atom] -> Maybe Atom) -> [Atom] -> Maybe Atom
forall a b. (a -> b) -> a -> b
$ (Atom -> Bool) -> [Atom] -> [Atom]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Atom
a -> Atom -> ByteString
atomName Atom
a ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
name) [Atom]
atoms
findAtomPath [Atom]
atoms (ByteString
name:[ByteString]
rest) = do
  Atom
atom <- [Atom] -> Maybe Atom
forall a. [a] -> Maybe a
listToMaybe ([Atom] -> Maybe Atom) -> [Atom] -> Maybe Atom
forall a b. (a -> b) -> a -> b
$ (Atom -> Bool) -> [Atom] -> [Atom]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Atom
a -> Atom -> ByteString
atomName Atom
a ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
name) [Atom]
atoms
  [Atom]
children <- Atom -> Maybe [Atom]
atomChildren Atom
atom
  [Atom] -> [ByteString] -> Maybe Atom
findAtomPath [Atom]
children [ByteString]
rest

-- | Extract metadata from ilst atom
extractMetadata :: Handle -> [Atom] -> Metadata -> IO Metadata
extractMetadata :: Handle -> [Atom] -> Metadata -> IO Metadata
extractMetadata Handle
handle [Atom]
atoms Metadata
metadata = do
  -- Debug: check what atoms we have
  -- putStrLn $ "Top level atoms: " ++ show (map atomName atoms)
  case [Atom] -> [ByteString] -> Maybe Atom
findAtomPath [Atom]
atoms [ByteString
"moov", ByteString
"udta", ByteString
"meta", ByteString
"ilst"] of
    Maybe Atom
Nothing -> do
      -- putStrLn "ilst atom not found!"
      Metadata -> IO Metadata
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Metadata
metadata
    Just Atom
ilstAtom -> do
      -- putStrLn $ "Found ilst, children: " ++ show (fmap (map atomName) (atomChildren ilstAtom))
      case Atom -> Maybe [Atom]
atomChildren Atom
ilstAtom of
        Maybe [Atom]
Nothing -> Metadata -> IO Metadata
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Metadata
metadata
        Just [Atom]
children -> do
          -- Parse each tag atom
          [[(Text, Text)]]
tags <- (Atom -> IO [(Text, Text)]) -> [Atom] -> IO [[(Text, Text)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Handle -> Atom -> IO [(Text, Text)]
parseTagAtom Handle
handle) [Atom]
children
          let tagMap :: HashMap Text Text
tagMap = [(Text, Text)] -> HashMap Text Text
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Text, Text)] -> HashMap Text Text)
-> [(Text, Text)] -> HashMap Text Text
forall a b. (a -> b) -> a -> b
$ [[(Text, Text)]] -> [(Text, Text)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Text, Text)]]
tags

          -- Parse album art info separately
          Maybe AlbumArtInfo
artInfo <- Handle -> [Atom] -> IO (Maybe AlbumArtInfo)
extractAlbumArtInfo Handle
handle [Atom]
children

          Metadata -> IO Metadata
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Metadata -> IO Metadata) -> Metadata -> IO Metadata
forall a b. (a -> b) -> a -> b
$ (HashMap Text Text -> Metadata -> Metadata
applyTags HashMap Text Text
tagMap Metadata
metadata) { albumArtInfo = artInfo }

-- | Parse a single tag atom from ilst
parseTagAtom :: Handle -> Atom -> IO [(Text, Text)]
parseTagAtom :: Handle -> Atom -> IO [(Text, Text)]
parseTagAtom Handle
handle Atom
atom = do
  Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek (Atom -> Integer
atomDataOffset Atom
atom)
  let dataSize :: Int
dataSize = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Atom -> Word64
atomSize Atom
atom) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Atom -> Integer
atomDataOffset Atom
atom Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Atom -> Integer
atomOffset Atom
atom)

  if Int
dataSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
    then [(Text, Text)] -> IO [(Text, Text)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    else do
      ByteString
atomData <- Handle -> Int -> IO ByteString
BS.hGet Handle
handle Int
dataSize
      [(Text, Text)] -> IO [(Text, Text)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Text, Text)] -> IO [(Text, Text)])
-> [(Text, Text)] -> IO [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> [(Text, Text)]
parseTagData (Atom -> ByteString
atomName Atom
atom) ByteString
atomData

-- | Parse tag data - handles special atoms differently
parseTagData :: BS.ByteString -> BS.ByteString -> [(Text, Text)]
parseTagData :: ByteString -> ByteString -> [(Text, Text)]
parseTagData ByteString
"trkn" ByteString
bs = ByteString -> ByteString -> [(Text, Text)]
parseTrackDiskAtom ByteString
"trkn" ByteString
bs
parseTagData ByteString
"disk" ByteString
bs = ByteString -> ByteString -> [(Text, Text)]
parseTrackDiskAtom ByteString
"disk" ByteString
bs
parseTagData ByteString
"covr" ByteString
_bs = []  -- Skip cover art in text parsing
parseTagData ByteString
"----" ByteString
bs = ByteString -> [(Text, Text)]
parseFreeformAtom ByteString
bs  -- Freeform/custom tags
parseTagData ByteString
name ByteString
bs = ByteString -> ByteString -> [(Text, Text)]
parseDataAtoms ByteString
name ByteString
bs

-- | Parse track/disk number atoms (special binary format)
parseTrackDiskAtom :: BS.ByteString -> BS.ByteString -> [(Text, Text)]
parseTrackDiskAtom :: ByteString -> ByteString -> [(Text, Text)]
parseTrackDiskAtom ByteString
tagName ByteString
bs
  | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
16 = []
  | Bool
otherwise =
      let size :: Word32
size = Get Word32 -> ByteString -> Word32
forall a. Get a -> ByteString -> a
runGet Get Word32
getWord32be (ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
4 ByteString
bs)
          dataName :: ByteString
dataName = Int -> ByteString -> ByteString
BS.take Int
4 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
4 ByteString
bs
      in if ByteString
dataName ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"data" Bool -> Bool -> Bool
|| Word32
size Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
16
        then []
        else
          -- Data atom structure: [size:4][name:4][version/flags:4][data...]
          -- The flags contain the data type. Content starts at offset 16.
          let dataContent :: ByteString
dataContent = Int -> ByteString -> ByteString
BS.take (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
16) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
16 ByteString
bs
              -- Atom names use Latin-1 encoding
              key :: Text
key = ByteString -> Text
TE.decodeLatin1 ByteString
tagName
          in if ByteString -> Int
BS.length ByteString
dataContent Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
6
            then
              let current :: Word16
current = Get Word16 -> ByteString -> Word16
forall a. Get a -> ByteString -> a
runGet Get Word16
getWord16be (ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
2 ByteString
dataContent)
                  total :: Word16
total = Get Word16 -> ByteString -> Word16
forall a. Get a -> ByteString -> a
runGet Get Word16
getWord16be (ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
4 ByteString
dataContent)
                  currentText :: Text
currentText = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word16 -> String
forall a. Show a => a -> String
show Word16
current
                  totalText :: Text
totalText = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word16 -> String
forall a. Show a => a -> String
show Word16
total
              in [(Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":current", Text
currentText), (Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":total", Text
totalText)]
            else []

-- | Parse data atoms within a tag atom
parseDataAtoms :: BS.ByteString -> BS.ByteString -> [(Text, Text)]
parseDataAtoms :: ByteString -> ByteString -> [(Text, Text)]
parseDataAtoms ByteString
tagName ByteString
bs
  | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
16 = []
  | Bool
otherwise =
      let size :: Word32
size = Get Word32 -> ByteString -> Word32
forall a. Get a -> ByteString -> a
runGet Get Word32
getWord32be (ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
4 ByteString
bs)
          dataName :: ByteString
dataName = Int -> ByteString -> ByteString
BS.take Int
4 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
4 ByteString
bs
      in if ByteString
dataName ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"data" Bool -> Bool -> Bool
|| Word32
size Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
16
        then []
        else
          -- Data atom structure: [size:4][name:4][version/flags:4][data...]
          -- The flags (lower 3 bytes of version/flags) contain the data type
          -- Offsets: 0=size, 4=name, 8=version/flags, 12=data
          let versionFlags :: Word32
versionFlags = Get Word32 -> ByteString -> Word32
forall a. Get a -> ByteString -> a
runGet Get Word32
getWord32be (ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
4 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
8 ByteString
bs)
              dataType :: Word32
dataType = Word32
versionFlags  -- The whole field is used as type (version is always 0)
              dataContent :: ByteString
dataContent = Int -> ByteString -> ByteString
BS.take (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
16) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
16 ByteString
bs
              rest :: ByteString
rest = Int -> ByteString -> ByteString
BS.drop (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size) ByteString
bs

              -- Decode based on type
              value :: Text
value = Word32 -> ByteString -> Text
decodeDataValue Word32
dataType ByteString
dataContent
              -- Atom names use Latin-1 encoding (©nam is 0xA9 0x6E 0x61 0x6D)
              key :: Text
key = ByteString -> Text
TE.decodeLatin1 ByteString
tagName

              current :: [(Text, Text)]
current = if Bool -> Bool
not (Text -> Bool
T.null Text
value) then [(Text
key, Text
value)] else []
              next :: [(Text, Text)]
next = if ByteString -> Int
BS.length ByteString
rest Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
16 then ByteString -> ByteString -> [(Text, Text)]
parseDataAtoms ByteString
tagName ByteString
rest else []
          in [(Text, Text)]
current [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ [(Text, Text)]
next

-- | Decode data value based on type flags
decodeDataValue :: Word32 -> BS.ByteString -> Text
decodeDataValue :: Word32 -> ByteString -> Text
decodeDataValue Word32
flags ByteString
bs
  | Word32
flags Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
1 = OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TEE.lenientDecode ByteString
bs  -- UTF-8
  | Word32
flags Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
2 = OnDecodeError -> ByteString -> Text
TE.decodeUtf16BEWith OnDecodeError
TEE.lenientDecode ByteString
bs  -- UTF-16BE
  | Word32
flags Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
13 Bool -> Bool -> Bool
|| Word32
flags Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
14 = Text
""  -- JPEG/PNG (skip for text parsing)
  | Word32
flags Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
21 = ByteString -> Text
decodeInteger ByteString
bs  -- Integer
  | Word32
flags Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 = ByteString -> Text
decodeInteger ByteString
bs  -- Implicit (often integer)
  | Bool
otherwise = OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TEE.lenientDecode ByteString
bs

-- | Decode integer from bytes
decodeInteger :: BS.ByteString -> Text
decodeInteger :: ByteString -> Text
decodeInteger ByteString
bs
  | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word8 -> String
forall a. Show a => a -> String
show (Word8 -> String) -> Word8 -> String
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bs Int
0
  | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word16 -> String
forall a. Show a => a -> String
show (Word16 -> String) -> Word16 -> String
forall a b. (a -> b) -> a -> b
$ Get Word16 -> ByteString -> Word16
forall a. Get a -> ByteString -> a
runGet Get Word16
getWord16be (ByteString -> ByteString
L.fromStrict ByteString
bs)
  | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word32 -> String
forall a. Show a => a -> String
show (Word32 -> String) -> Word32 -> String
forall a b. (a -> b) -> a -> b
$ Get Word32 -> ByteString -> Word32
forall a. Get a -> ByteString -> a
runGet Get Word32
getWord32be (ByteString -> ByteString
L.fromStrict ByteString
bs)
  | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word64 -> String
forall a. Show a => a -> String
show (Word64 -> String) -> Word64 -> String
forall a b. (a -> b) -> a -> b
$ Get Word64 -> ByteString -> Word64
forall a. Get a -> ByteString -> a
runGet Get Word64
getWord64be (ByteString -> ByteString
L.fromStrict ByteString
bs)
  | Bool
otherwise = Text
""

-- | Parse freeform (----) atoms
-- Structure: [mean atom][name atom][data atom(s)]
parseFreeformAtom :: BS.ByteString -> [(Text, Text)]
parseFreeformAtom :: ByteString -> [(Text, Text)]
parseFreeformAtom ByteString
bs
  | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
20 = []  -- Need at least mean header
  | Bool
otherwise =
      let meanSize :: Word32
meanSize = Get Word32 -> ByteString -> Word32
forall a. Get a -> ByteString -> a
runGet Get Word32
getWord32be (ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
4 ByteString
bs)
          meanName :: ByteString
meanName = Int -> ByteString -> ByteString
BS.take Int
4 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
4 ByteString
bs
      in if ByteString
meanName ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"mean" Bool -> Bool -> Bool
|| Word32
meanSize Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
12
        then []
        else
          let meanDataSize :: Int
meanDataSize = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
meanSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
12
              meanData :: ByteString
meanData = Int -> ByteString -> ByteString
BS.take Int
meanDataSize (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
12 ByteString
bs
              afterMean :: ByteString
afterMean = Int -> ByteString -> ByteString
BS.drop (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
meanSize) ByteString
bs

              -- Parse name atom
              nameSize :: Word32
nameSize = if ByteString -> Int
BS.length ByteString
afterMean Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
4
                        then Get Word32 -> ByteString -> Word32
forall a. Get a -> ByteString -> a
runGet Get Word32
getWord32be (ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
4 ByteString
afterMean)
                        else Word32
0
              nameAtomName :: ByteString
nameAtomName = if ByteString -> Int
BS.length ByteString
afterMean Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
8
                            then Int -> ByteString -> ByteString
BS.take Int
4 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
4 ByteString
afterMean
                            else ByteString
""
          in if ByteString
nameAtomName ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"name" Bool -> Bool -> Bool
|| Word32
nameSize Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
12
            then []
            else
              let nameDataSize :: Int
nameDataSize = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
nameSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
12
                  nameData :: ByteString
nameData = Int -> ByteString -> ByteString
BS.take Int
nameDataSize (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
12 ByteString
afterMean
                  afterName :: ByteString
afterName = Int -> ByteString -> ByteString
BS.drop (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
nameSize) ByteString
afterMean

                  -- Build key as "----:mean:name"
                  meanText :: Text
meanText = OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TEE.lenientDecode ByteString
meanData
                  nameText :: Text
nameText = OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TEE.lenientDecode ByteString
nameData
                  key :: Text
key = Text
"----:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
meanText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nameText

                  -- Parse data atom(s) - reuse parseDataAtoms logic
                  -- The remaining bytes should be data atom(s)
              in ByteString -> ByteString -> [(Text, Text)]
parseDataAtoms (Text -> ByteString
TE.encodeUtf8 Text
key) ByteString
afterName

-- | Apply parsed tags to metadata
applyTags :: HM.HashMap Text Text -> Metadata -> Metadata
applyTags :: HashMap Text Text -> Metadata -> Metadata
applyTags HashMap Text Text
tags Metadata
metadata = 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
  , 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
  , rawTags = tags
  }
  where
    extractYear :: Text -> Maybe Int
extractYear Text
dateText =
      let yearStr :: Text
yearStr = (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') Text
dateText
      in Text -> Maybe Int
readInt Text
yearStr

    -- Helper to look up freeform tags with common mean prefix
    lookupFreeform :: Text -> HM.HashMap Text Text -> Maybe Text
    lookupFreeform :: Text -> HashMap Text Text -> Maybe Text
lookupFreeform Text
name HashMap Text Text
tagMap =
      Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Text
"----:com.apple.iTunes:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name) HashMap Text Text
tagMap

    extractMusicBrainzIds :: HashMap Text Text -> MusicBrainzIds
extractMusicBrainzIds HashMap Text Text
tagMap = MusicBrainzIds
      { mbTrackId :: Maybe Text
mbTrackId = Text -> HashMap Text Text -> Maybe Text
lookupFreeform Text
"MusicBrainz Release Track Id" HashMap Text Text
tagMap
      , mbRecordingId :: Maybe Text
mbRecordingId = Text -> HashMap Text Text -> Maybe Text
lookupFreeform Text
"MusicBrainz Track Id" HashMap Text Text
tagMap
      , mbReleaseId :: Maybe Text
mbReleaseId = Text -> HashMap Text Text -> Maybe Text
lookupFreeform Text
"MusicBrainz Album Id" HashMap Text Text
tagMap
      , mbReleaseGroupId :: Maybe Text
mbReleaseGroupId = Text -> HashMap Text Text -> Maybe Text
lookupFreeform Text
"MusicBrainz Release Group Id" HashMap Text Text
tagMap
      , mbArtistId :: Maybe Text
mbArtistId = Text -> HashMap Text Text -> Maybe Text
lookupFreeform Text
"MusicBrainz Artist Id" HashMap Text Text
tagMap
      , mbAlbumArtistId :: Maybe Text
mbAlbumArtistId = Text -> HashMap Text Text -> Maybe Text
lookupFreeform Text
"MusicBrainz Album Artist Id" HashMap Text Text
tagMap
      , mbWorkId :: Maybe Text
mbWorkId = Text -> HashMap Text Text -> Maybe Text
lookupFreeform Text
"MusicBrainz Work Id" HashMap Text Text
tagMap
      , mbDiscId :: Maybe Text
mbDiscId = Text -> HashMap Text Text -> Maybe Text
lookupFreeform Text
"MusicBrainz Disc Id" HashMap Text Text
tagMap
      }

-- | Extract album art info from ilst children
extractAlbumArtInfo :: Handle -> [Atom] -> IO (Maybe AlbumArtInfo)
extractAlbumArtInfo :: Handle -> [Atom] -> IO (Maybe AlbumArtInfo)
extractAlbumArtInfo Handle
handle [Atom]
children = do
  case [Atom] -> Maybe Atom
forall a. [a] -> Maybe a
listToMaybe ([Atom] -> Maybe Atom) -> [Atom] -> Maybe Atom
forall a b. (a -> b) -> a -> b
$ (Atom -> Bool) -> [Atom] -> [Atom]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Atom
a -> Atom -> ByteString
atomName Atom
a ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"covr") [Atom]
children of
    Maybe Atom
Nothing -> Maybe AlbumArtInfo -> IO (Maybe AlbumArtInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AlbumArtInfo
forall a. Maybe a
Nothing
    Just Atom
covrAtom -> do
      Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek (Atom -> Integer
atomDataOffset Atom
covrAtom)
      let dataSize :: Int
dataSize = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Atom -> Word64
atomSize Atom
covrAtom) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Atom -> Integer
atomDataOffset Atom
covrAtom Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Atom -> Integer
atomOffset Atom
covrAtom)
      if Int
dataSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
        then Maybe AlbumArtInfo -> IO (Maybe AlbumArtInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AlbumArtInfo
forall a. Maybe a
Nothing
        else do
          ByteString
atomData <- Handle -> Int -> IO ByteString
BS.hGet Handle
handle Int
dataSize
          Maybe AlbumArtInfo -> IO (Maybe AlbumArtInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe AlbumArtInfo -> IO (Maybe AlbumArtInfo))
-> Maybe AlbumArtInfo -> IO (Maybe AlbumArtInfo)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe AlbumArtInfo
parseAlbumArtInfo ByteString
atomData

-- | Parse album art info (lightweight, no image data)
parseAlbumArtInfo :: BS.ByteString -> Maybe AlbumArtInfo
parseAlbumArtInfo :: ByteString -> Maybe AlbumArtInfo
parseAlbumArtInfo ByteString
bs
  | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
16 = Maybe AlbumArtInfo
forall a. Maybe a
Nothing
  | Bool
otherwise =
      let size :: Word32
size = Get Word32 -> ByteString -> Word32
forall a. Get a -> ByteString -> a
runGet Get Word32
getWord32be (ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
4 ByteString
bs)
          dataName :: ByteString
dataName = Int -> ByteString -> ByteString
BS.take Int
4 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
4 ByteString
bs
      in if ByteString
dataName ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"data" Bool -> Bool -> Bool
|| Word32
size Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
16
        then Maybe AlbumArtInfo
forall a. Maybe a
Nothing
        else
          let flags :: Word32
flags = Get Word32 -> ByteString -> Word32
forall a. Get a -> ByteString -> a
runGet Get Word32
getWord32be (ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
4 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
8 ByteString
bs)
              imageDataSize :: Int
imageDataSize = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
16
              mimeType :: Text
mimeType = case Word32
flags of
                Word32
13 -> Text
"image/jpeg"  -- JPEG
                Word32
14 -> Text
"image/png"   -- PNG
                Word32
27 -> Text
"image/bmp"   -- BMP
                Word32
_ -> Text
"image/unknown"
          in AlbumArtInfo -> Maybe AlbumArtInfo
forall a. a -> Maybe a
Just (AlbumArtInfo -> Maybe AlbumArtInfo)
-> AlbumArtInfo -> Maybe AlbumArtInfo
forall a b. (a -> b) -> a -> b
$ AlbumArtInfo
            { albumArtInfoMimeType :: Text
albumArtInfoMimeType = Text
mimeType
            , albumArtInfoPictureType :: Word8
albumArtInfoPictureType = Word8
3  -- Front cover (iTunes default)
            , albumArtInfoDescription :: Text
albumArtInfoDescription = Text
""
            , albumArtInfoSizeBytes :: Int
albumArtInfoSizeBytes = Int
imageDataSize
            }

-- | Extract audio properties
extractAudioProperties :: Handle -> [Atom] -> IO AudioProperties
extractAudioProperties :: Handle -> [Atom] -> IO AudioProperties
extractAudioProperties Handle
handle [Atom]
atoms = do
  -- Get duration from mvhd atom
  Maybe Int
fileDuration <- Handle -> [Atom] -> IO (Maybe Int)
extractDuration Handle
handle [Atom]
atoms

  -- Find the first audio track
  case [Atom] -> Maybe Atom
findFirstAudioTrack [Atom]
atoms of
    Maybe Atom
Nothing -> AudioProperties -> IO AudioProperties
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return AudioProperties
emptyAudioProperties { duration = fileDuration }
    Just Atom
trak -> do
      AudioProperties
props <- Handle -> Atom -> IO AudioProperties
parseAudioTrack Handle
handle Atom
trak
      AudioProperties -> IO AudioProperties
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return AudioProperties
props { duration = fileDuration <|> Monatone.Metadata.duration props }

-- | Extract duration from mvhd atom
extractDuration :: Handle -> [Atom] -> IO (Maybe Int)
extractDuration :: Handle -> [Atom] -> IO (Maybe Int)
extractDuration Handle
handle [Atom]
atoms = do
  case [Atom] -> [ByteString] -> Maybe Atom
findAtomPath [Atom]
atoms [ByteString
"moov", ByteString
"mvhd"] of
    Maybe Atom
Nothing -> Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
    Just Atom
mvhdAtom -> do
      Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek (Atom -> Integer
atomDataOffset Atom
mvhdAtom)
      ByteString
mvhdData <- Handle -> Int -> IO ByteString
BS.hGet Handle
handle Int
32
      if ByteString -> Int
BS.length ByteString
mvhdData Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
20
        then Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
        else do
          let version :: Word8
version = HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
mvhdData Int
0
          if Word8
version Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0
            then do
              -- Version 0: 32-bit values
              let timescale :: Word32
timescale = Get Word32 -> ByteString -> Word32
forall a. Get a -> ByteString -> a
runGet Get Word32
getWord32be (ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
4 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
12 ByteString
mvhdData)
                  durationValue :: Word32
durationValue = Get Word32 -> ByteString -> Word32
forall a. Get a -> ByteString -> a
runGet Get Word32
getWord32be (ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
4 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
16 ByteString
mvhdData)
                  durationMs :: Maybe Int
durationMs = if Word32
timescale Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
0
                    then Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ (Word32 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
durationValue Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Word32 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
timescale :: Double) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000
                    else Maybe Int
forall a. Maybe a
Nothing
              Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
durationMs
            else if Word8
version Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
1
              then do
                -- Version 1: 64-bit values
                Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek (Atom -> Integer
atomDataOffset Atom
mvhdAtom)
                ByteString
mvhdDataLong <- Handle -> Int -> IO ByteString
BS.hGet Handle
handle Int
44
                if ByteString -> Int
BS.length ByteString
mvhdDataLong Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
36
                  then Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
                  else do
                    let timescale :: Word32
timescale = Get Word32 -> ByteString -> Word32
forall a. Get a -> ByteString -> a
runGet Get Word32
getWord32be (ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
4 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
20 ByteString
mvhdDataLong)
                        durationValue :: Word64
durationValue = Get Word64 -> ByteString -> Word64
forall a. Get a -> ByteString -> a
runGet Get Word64
getWord64be (ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
8 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
24 ByteString
mvhdDataLong)
                        durationMs :: Maybe Int
durationMs = if Word32
timescale Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
0
                          then Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
durationValue Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Word32 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
timescale :: Double) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000
                          else Maybe Int
forall a. Maybe a
Nothing
                    Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
durationMs
              else Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing

-- | Find first audio track
findFirstAudioTrack :: [Atom] -> Maybe Atom
findFirstAudioTrack :: [Atom] -> Maybe Atom
findFirstAudioTrack [Atom]
atoms = do
  Atom
moov <- [Atom] -> [ByteString] -> Maybe Atom
findAtomPath [Atom]
atoms [ByteString
"moov"]
  [Atom]
children <- Atom -> Maybe [Atom]
atomChildren Atom
moov
  [Atom] -> Maybe Atom
forall a. [a] -> Maybe a
listToMaybe ([Atom] -> Maybe Atom) -> [Atom] -> Maybe Atom
forall a b. (a -> b) -> a -> b
$ (Atom -> Bool) -> [Atom] -> [Atom]
forall a. (a -> Bool) -> [a] -> [a]
filter Atom -> Bool
isAudioTrack [Atom]
children
  where
    isAudioTrack :: Atom -> Bool
isAudioTrack Atom
atom = Atom -> ByteString
atomName Atom
atom ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"trak"

-- | Parse audio track properties
parseAudioTrack :: Handle -> Atom -> IO AudioProperties
parseAudioTrack :: Handle -> Atom -> IO AudioProperties
parseAudioTrack Handle
handle Atom
trak = do
  -- Find sample description
  case Atom -> Maybe [Atom]
atomChildren Atom
trak Maybe [Atom] -> ([Atom] -> Maybe Atom) -> Maybe Atom
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Atom]
c -> [Atom] -> [ByteString] -> Maybe Atom
findAtomPath [Atom]
c [ByteString
"mdia", ByteString
"minf", ByteString
"stbl", ByteString
"stsd"] of
    Maybe Atom
Nothing -> AudioProperties -> IO AudioProperties
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return AudioProperties
emptyAudioProperties
    Just Atom
stsdAtom -> do
      -- Parse stsd atom
      Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek (Atom -> Integer
atomDataOffset Atom
stsdAtom)
      ByteString
stsdHeader <- Handle -> Int -> IO ByteString
BS.hGet Handle
handle Int
8
      if ByteString -> Int
BS.length ByteString
stsdHeader Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8
        then AudioProperties -> IO AudioProperties
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return AudioProperties
emptyAudioProperties
        else do
          -- Skip version/flags (4 bytes) and entry count (4 bytes)
          -- Read first sample entry
          Maybe Atom
sampleEntry <- Handle -> Int -> IO (Maybe Atom)
parseAtom Handle
handle Int
0
          case Maybe Atom
sampleEntry of
            Maybe Atom
Nothing -> AudioProperties -> IO AudioProperties
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return AudioProperties
emptyAudioProperties
            Just Atom
entry -> Handle -> Atom -> IO AudioProperties
parseSampleEntry Handle
handle Atom
entry

-- | Parse sample entry (mp4a, alac, etc.)
parseSampleEntry :: Handle -> Atom -> IO AudioProperties
parseSampleEntry :: Handle -> Atom -> IO AudioProperties
parseSampleEntry Handle
handle Atom
entry = do
  Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek (Atom -> Integer
atomDataOffset Atom
entry)
  ByteString
entryData <- Handle -> Int -> IO ByteString
BS.hGet Handle
handle Int
28  -- AudioSampleEntry header

  if ByteString -> Int
BS.length ByteString
entryData Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
28
    then AudioProperties -> IO AudioProperties
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return AudioProperties
emptyAudioProperties
    else do
      let entryChannels :: Word16
entryChannels = Get Word16 -> ByteString -> Word16
forall a. Get a -> ByteString -> a
runGet Get Word16
getWord16be (ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
2 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
16 ByteString
entryData)
          entrySampleSize :: Word16
entrySampleSize = Get Word16 -> ByteString -> Word16
forall a. Get a -> ByteString -> a
runGet Get Word16
getWord16be (ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
2 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
18 ByteString
entryData)
          entrySampleRate :: Word32
entrySampleRate = (Get Word32 -> ByteString -> Word32
forall a. Get a -> ByteString -> a
runGet Get Word32
getWord32be (ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
4 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
24 ByteString
entryData)) Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`div` Word32
65536

          codec :: ByteString
codec = Atom -> ByteString
atomName Atom
entry

      -- Parse extension atoms for more details
      case Atom -> Maybe [Atom]
atomChildren Atom
entry of
        Maybe [Atom]
Nothing -> AudioProperties -> IO AudioProperties
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AudioProperties -> IO AudioProperties)
-> AudioProperties -> IO AudioProperties
forall a b. (a -> b) -> a -> b
$ AudioProperties
emptyAudioProperties
          { channels = Just $ fromIntegral entryChannels
          , bitsPerSample = Just $ fromIntegral entrySampleSize
          , sampleRate = Just $ fromIntegral entrySampleRate
          }
        Just [Atom]
exts -> do
          -- Look for esds (AAC) or alac atoms
          let esdsAtom :: Maybe Atom
esdsAtom = [Atom] -> Maybe Atom
forall a. [a] -> Maybe a
listToMaybe ([Atom] -> Maybe Atom) -> [Atom] -> Maybe Atom
forall a b. (a -> b) -> a -> b
$ (Atom -> Bool) -> [Atom] -> [Atom]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Atom
a -> Atom -> ByteString
atomName Atom
a ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"esds") [Atom]
exts
          let alacAtom :: Maybe Atom
alacAtom = [Atom] -> Maybe Atom
forall a. [a] -> Maybe a
listToMaybe ([Atom] -> Maybe Atom) -> [Atom] -> Maybe Atom
forall a b. (a -> b) -> a -> b
$ (Atom -> Bool) -> [Atom] -> [Atom]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Atom
a -> Atom -> ByteString
atomName Atom
a ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"alac") [Atom]
exts

          case (ByteString
codec, Maybe Atom
esdsAtom, Maybe Atom
alacAtom) of
            (ByteString
"mp4a", Just Atom
esds, Maybe Atom
_) -> Handle -> Atom -> Word16 -> Word16 -> Word32 -> IO AudioProperties
parseEsdsAtom Handle
handle Atom
esds Word16
entryChannels Word16
entrySampleSize Word32
entrySampleRate
            (ByteString
"alac", Maybe Atom
_, Just Atom
alac) -> Handle -> Atom -> IO AudioProperties
parseAlacAtom Handle
handle Atom
alac
            (ByteString, Maybe Atom, Maybe Atom)
_ -> AudioProperties -> IO AudioProperties
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AudioProperties -> IO AudioProperties)
-> AudioProperties -> IO AudioProperties
forall a b. (a -> b) -> a -> b
$ AudioProperties
emptyAudioProperties
              { channels = Just $ fromIntegral entryChannels
              , bitsPerSample = Just $ fromIntegral entrySampleSize
              , sampleRate = Just $ fromIntegral entrySampleRate
              }

-- | Parse ESDS atom for AAC info
parseEsdsAtom :: Handle -> Atom -> Word16 -> Word16 -> Word32 -> IO AudioProperties
parseEsdsAtom :: Handle -> Atom -> Word16 -> Word16 -> Word32 -> IO AudioProperties
parseEsdsAtom Handle
handle Atom
esds Word16
chans Word16
sampSize Word32
sampRate = do
  Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek (Atom -> Integer
atomDataOffset Atom
esds)
  ByteString
_esdsData <- Handle -> Int -> IO ByteString
BS.hGet Handle
handle Int
64  -- Should be enough

  -- For now, return basic info
  -- Full ESDS parsing is complex, would need to parse descriptors
  AudioProperties -> IO AudioProperties
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return AudioProperties
emptyAudioProperties
    { channels = Just $ fromIntegral chans
    , bitsPerSample = Just $ fromIntegral sampSize
    , sampleRate = Just $ fromIntegral sampRate
    }

-- | Parse ALAC atom for Apple Lossless info
parseAlacAtom :: Handle -> Atom -> IO AudioProperties
parseAlacAtom :: Handle -> Atom -> IO AudioProperties
parseAlacAtom Handle
handle Atom
alac = do
  Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek (Atom -> Integer
atomDataOffset Atom
alac)
  ByteString
alacData <- Handle -> Int -> IO ByteString
BS.hGet Handle
handle Int
36

  if ByteString -> Int
BS.length ByteString
alacData Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
28
    then AudioProperties -> IO AudioProperties
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return AudioProperties
emptyAudioProperties
    else do
      -- Skip version/flags (4 bytes) + frameLength (4 bytes) + compatibleVersion (1 byte)
      let alacSampleSize :: Word8
alacSampleSize = HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
alacData Int
9
          alacChannels :: Word8
alacChannels = HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
alacData Int
13
          alacSampleRate :: Word32
alacSampleRate = Get Word32 -> ByteString -> Word32
forall a. Get a -> ByteString -> a
runGet Get Word32
getWord32be (ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
4 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
20 ByteString
alacData)

      AudioProperties -> IO AudioProperties
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return AudioProperties
emptyAudioProperties
        { channels = Just $ fromIntegral alacChannels
        , bitsPerSample = Just $ fromIntegral alacSampleSize
        , sampleRate = Just $ fromIntegral alacSampleRate
        }

-- | Load album art from M4A file (full binary data for writing)
loadAlbumArtM4A :: OsPath -> Parser (Maybe AlbumArt)
loadAlbumArtM4A :: OsPath -> Parser (Maybe AlbumArt)
loadAlbumArtM4A OsPath
filePath = do
  Either ParseError (Maybe AlbumArt)
result <- IO (Either ParseError (Maybe AlbumArt))
-> ExceptT ParseError IO (Either ParseError (Maybe AlbumArt))
forall a. IO a -> ExceptT ParseError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ParseError (Maybe AlbumArt))
 -> ExceptT ParseError IO (Either ParseError (Maybe AlbumArt)))
-> IO (Either ParseError (Maybe AlbumArt))
-> ExceptT ParseError IO (Either ParseError (Maybe AlbumArt))
forall a b. (a -> b) -> a -> b
$ OsPath
-> IOMode
-> (Handle -> IO (Either ParseError (Maybe AlbumArt)))
-> IO (Either ParseError (Maybe AlbumArt))
forall r. OsPath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile OsPath
filePath IOMode
ReadMode ((Handle -> IO (Either ParseError (Maybe AlbumArt)))
 -> IO (Either ParseError (Maybe AlbumArt)))
-> (Handle -> IO (Either ParseError (Maybe AlbumArt)))
-> IO (Either ParseError (Maybe AlbumArt))
forall a b. (a -> b) -> a -> b
$ \Handle
handle -> do
    [Atom]
atoms <- Handle -> IO [Atom]
parseAtoms Handle
handle

    case [Atom] -> [ByteString] -> Maybe Atom
findAtomPath [Atom]
atoms [ByteString
"moov", ByteString
"udta", ByteString
"meta", ByteString
"ilst"] of
      Maybe Atom
Nothing -> Either ParseError (Maybe AlbumArt)
-> IO (Either ParseError (Maybe AlbumArt))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseError (Maybe AlbumArt)
 -> IO (Either ParseError (Maybe AlbumArt)))
-> Either ParseError (Maybe AlbumArt)
-> IO (Either ParseError (Maybe AlbumArt))
forall a b. (a -> b) -> a -> b
$ Maybe AlbumArt -> Either ParseError (Maybe AlbumArt)
forall a b. b -> Either a b
Right Maybe AlbumArt
forall a. Maybe a
Nothing
      Just Atom
ilstAtom -> do
        case Atom -> Maybe [Atom]
atomChildren Atom
ilstAtom of
          Maybe [Atom]
Nothing -> Either ParseError (Maybe AlbumArt)
-> IO (Either ParseError (Maybe AlbumArt))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseError (Maybe AlbumArt)
 -> IO (Either ParseError (Maybe AlbumArt)))
-> Either ParseError (Maybe AlbumArt)
-> IO (Either ParseError (Maybe AlbumArt))
forall a b. (a -> b) -> a -> b
$ Maybe AlbumArt -> Either ParseError (Maybe AlbumArt)
forall a b. b -> Either a b
Right Maybe AlbumArt
forall a. Maybe a
Nothing
          Just [Atom]
children -> do
            case [Atom] -> Maybe Atom
forall a. [a] -> Maybe a
listToMaybe ([Atom] -> Maybe Atom) -> [Atom] -> Maybe Atom
forall a b. (a -> b) -> a -> b
$ (Atom -> Bool) -> [Atom] -> [Atom]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Atom
a -> Atom -> ByteString
atomName Atom
a ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"covr") [Atom]
children of
              Maybe Atom
Nothing -> Either ParseError (Maybe AlbumArt)
-> IO (Either ParseError (Maybe AlbumArt))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseError (Maybe AlbumArt)
 -> IO (Either ParseError (Maybe AlbumArt)))
-> Either ParseError (Maybe AlbumArt)
-> IO (Either ParseError (Maybe AlbumArt))
forall a b. (a -> b) -> a -> b
$ Maybe AlbumArt -> Either ParseError (Maybe AlbumArt)
forall a b. b -> Either a b
Right Maybe AlbumArt
forall a. Maybe a
Nothing
              Just Atom
covrAtom -> do
                Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek (Atom -> Integer
atomDataOffset Atom
covrAtom)
                let dataSize :: Int
dataSize = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Atom -> Word64
atomSize Atom
covrAtom) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Atom -> Integer
atomDataOffset Atom
covrAtom Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Atom -> Integer
atomOffset Atom
covrAtom)
                if Int
dataSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
                  then Either ParseError (Maybe AlbumArt)
-> IO (Either ParseError (Maybe AlbumArt))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseError (Maybe AlbumArt)
 -> IO (Either ParseError (Maybe AlbumArt)))
-> Either ParseError (Maybe AlbumArt)
-> IO (Either ParseError (Maybe AlbumArt))
forall a b. (a -> b) -> a -> b
$ Maybe AlbumArt -> Either ParseError (Maybe AlbumArt)
forall a b. b -> Either a b
Right Maybe AlbumArt
forall a. Maybe a
Nothing
                  else do
                    ByteString
atomData <- Handle -> Int -> IO ByteString
BS.hGet Handle
handle Int
dataSize
                    Either ParseError (Maybe AlbumArt)
-> IO (Either ParseError (Maybe AlbumArt))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseError (Maybe AlbumArt)
 -> IO (Either ParseError (Maybe AlbumArt)))
-> Either ParseError (Maybe AlbumArt)
-> IO (Either ParseError (Maybe AlbumArt))
forall a b. (a -> b) -> a -> b
$ Maybe AlbumArt -> Either ParseError (Maybe AlbumArt)
forall a b. b -> Either a b
Right (Maybe AlbumArt -> Either ParseError (Maybe AlbumArt))
-> Maybe AlbumArt -> Either ParseError (Maybe AlbumArt)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe AlbumArt
parseAlbumArtFull ByteString
atomData

  case Either ParseError (Maybe AlbumArt)
result of
    Left ParseError
err -> ParseError -> Parser (Maybe AlbumArt)
forall a. ParseError -> ExceptT ParseError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ParseError
err
    Right Maybe AlbumArt
maybeArt -> Maybe AlbumArt -> Parser (Maybe AlbumArt)
forall a. a -> ExceptT ParseError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AlbumArt
maybeArt

-- | Parse album art with full image data
parseAlbumArtFull :: BS.ByteString -> Maybe AlbumArt
parseAlbumArtFull :: ByteString -> Maybe AlbumArt
parseAlbumArtFull ByteString
bs
  | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
16 = Maybe AlbumArt
forall a. Maybe a
Nothing
  | Bool
otherwise =
      let size :: Word32
size = Get Word32 -> ByteString -> Word32
forall a. Get a -> ByteString -> a
runGet Get Word32
getWord32be (ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
4 ByteString
bs)
          dataName :: ByteString
dataName = Int -> ByteString -> ByteString
BS.take Int
4 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
4 ByteString
bs
      in if ByteString
dataName ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"data" Bool -> Bool -> Bool
|| Word32
size Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
16
        then Maybe AlbumArt
forall a. Maybe a
Nothing
        else
          let flags :: Word32
flags = Get Word32 -> ByteString -> Word32
forall a. Get a -> ByteString -> a
runGet Get Word32
getWord32be (ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
4 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
8 ByteString
bs)
              imageData :: ByteString
imageData = Int -> ByteString -> ByteString
BS.take (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
16) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
16 ByteString
bs
              mimeType :: Text
mimeType = case Word32
flags of
                Word32
13 -> Text
"image/jpeg"  -- JPEG
                Word32
14 -> Text
"image/png"   -- PNG
                Word32
27 -> Text
"image/bmp"   -- BMP
                Word32
_ -> Text
"image/unknown"
          in AlbumArt -> Maybe AlbumArt
forall a. a -> Maybe a
Just (AlbumArt -> Maybe AlbumArt) -> AlbumArt -> Maybe AlbumArt
forall a b. (a -> b) -> a -> b
$ AlbumArt
            { albumArtMimeType :: Text
albumArtMimeType = Text
mimeType
            , albumArtPictureType :: Word8
albumArtPictureType = Word8
3  -- Front cover
            , albumArtDescription :: Text
albumArtDescription = Text
""
            , albumArtData :: ByteString
albumArtData = ByteString
imageData
            }