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

module Monatone.M4A.Writer
  ( writeM4AMetadata
  , WriteError(..)
  , Writer
  ) where

import Control.Exception (catch, IOException)
import Control.Monad.Except (ExceptT, throwError, runExceptT)
import Control.Monad.IO.Class (liftIO)
import Data.Binary.Put
import Data.Bits ((.|.), shiftL)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
import Data.Maybe (fromMaybe, maybeToList)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Word
import System.IO hiding (withBinaryFile)
import System.OsPath
import System.File.OsPath (withBinaryFile)
import System.IO.Temp (withSystemTempFile)

import Monatone.Metadata

-- Re-define WriteError and Writer locally to avoid circular imports
data WriteError
  = WriteIOError Text
  | UnsupportedWriteFormat AudioFormat
  | InvalidMetadata Text
  | CorruptedWrite Text
  deriving (Int -> WriteError -> ShowS
[WriteError] -> ShowS
WriteError -> String
(Int -> WriteError -> ShowS)
-> (WriteError -> String)
-> ([WriteError] -> ShowS)
-> Show WriteError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WriteError -> ShowS
showsPrec :: Int -> WriteError -> ShowS
$cshow :: WriteError -> String
show :: WriteError -> String
$cshowList :: [WriteError] -> ShowS
showList :: [WriteError] -> ShowS
Show, WriteError -> WriteError -> Bool
(WriteError -> WriteError -> Bool)
-> (WriteError -> WriteError -> Bool) -> Eq WriteError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WriteError -> WriteError -> Bool
== :: WriteError -> WriteError -> Bool
$c/= :: WriteError -> WriteError -> Bool
/= :: WriteError -> WriteError -> Bool
Eq)

type Writer = ExceptT WriteError IO

-- | Write metadata to M4A file
-- M4A writing requires rewriting the entire moov atom, so we use a temp file approach
writeM4AMetadata :: Metadata -> Maybe AlbumArt -> OsPath -> Writer ()
writeM4AMetadata :: Metadata -> Maybe AlbumArt -> OsPath -> Writer ()
writeM4AMetadata Metadata
metadata Maybe AlbumArt
maybeAlbumArt OsPath
filePath = do
  Either IOException (Either WriteError ())
result <- IO (Either IOException (Either WriteError ()))
-> ExceptT
     WriteError IO (Either IOException (Either WriteError ()))
forall a. IO a -> ExceptT WriteError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException (Either WriteError ()))
 -> ExceptT
      WriteError IO (Either IOException (Either WriteError ())))
-> IO (Either IOException (Either WriteError ()))
-> ExceptT
     WriteError IO (Either IOException (Either WriteError ()))
forall a b. (a -> b) -> a -> b
$ IO (Either WriteError ())
-> IO (Either IOException (Either WriteError ()))
forall a. IO a -> IO (Either IOException a)
tryIO (IO (Either WriteError ())
 -> IO (Either IOException (Either WriteError ())))
-> IO (Either WriteError ())
-> IO (Either IOException (Either WriteError ()))
forall a b. (a -> b) -> a -> b
$ do
    -- Create temp file
    String
-> (String -> Handle -> IO (Either WriteError ()))
-> IO (Either WriteError ())
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile String
"monatone-m4a.tmp" ((String -> Handle -> IO (Either WriteError ()))
 -> IO (Either WriteError ()))
-> (String -> Handle -> IO (Either WriteError ()))
-> IO (Either WriteError ())
forall a b. (a -> b) -> a -> b
$ \String
tmpPath Handle
tmpHandle -> do
      Handle -> IO ()
hClose Handle
tmpHandle  -- Close it so we can use withBinaryFile
      OsPath
tmpOsPath <- String -> IO OsPath
encodeFS String
tmpPath

      -- Copy file with updated metadata
      Writer () -> IO (Either WriteError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (Writer () -> IO (Either WriteError ()))
-> Writer () -> IO (Either WriteError ())
forall a b. (a -> b) -> a -> b
$ do
        OsPath -> OsPath -> Metadata -> Maybe AlbumArt -> Writer ()
copyM4AWithMetadata OsPath
filePath OsPath
tmpOsPath Metadata
metadata Maybe AlbumArt
maybeAlbumArt
        -- Copy temp file back to original
        IO () -> Writer ()
forall a. IO a -> ExceptT WriteError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Writer ()) -> IO () -> Writer ()
forall a b. (a -> b) -> a -> b
$ OsPath -> OsPath -> IO ()
copyFileContents OsPath
tmpOsPath OsPath
filePath

  case Either IOException (Either WriteError ())
result of
    Left (IOException
e :: IOException) -> WriteError -> Writer ()
forall a. WriteError -> ExceptT WriteError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (WriteError -> Writer ()) -> WriteError -> Writer ()
forall a b. (a -> b) -> a -> b
$ Text -> WriteError
WriteIOError (Text -> WriteError) -> Text -> WriteError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ IOException -> String
forall a. Show a => a -> String
show IOException
e
    Right (Left WriteError
err) -> WriteError -> Writer ()
forall a. WriteError -> ExceptT WriteError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError WriteError
err
    Right (Right ()) -> () -> Writer ()
forall a. a -> ExceptT WriteError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    tryIO :: IO a -> IO (Either IOException a)
    tryIO :: forall a. IO a -> IO (Either IOException a)
tryIO IO a
action = IO (Either IOException a)
-> (IOException -> IO (Either IOException a))
-> IO (Either IOException a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (a -> Either IOException a
forall a b. b -> Either a b
Right (a -> Either IOException a) -> IO a -> IO (Either IOException a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
action) (Either IOException a -> IO (Either IOException a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either IOException a -> IO (Either IOException a))
-> (IOException -> Either IOException a)
-> IOException
-> IO (Either IOException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> Either IOException a
forall a b. a -> Either a b
Left)

-- | Copy file contents
copyFileContents :: OsPath -> OsPath -> IO ()
copyFileContents :: OsPath -> OsPath -> IO ()
copyFileContents OsPath
src OsPath
dst = do
  OsPath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. OsPath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile OsPath
src IOMode
ReadMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
srcHandle -> do
    OsPath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. OsPath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile OsPath
dst IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
dstHandle -> do
      Handle -> Handle -> IO ()
copyLoop Handle
srcHandle Handle
dstHandle
  where
    copyLoop :: Handle -> Handle -> IO ()
copyLoop Handle
srcH Handle
dstH = do
      ByteString
chunk <- Handle -> Int -> IO ByteString
BS.hGet Handle
srcH Int
65536
      if ByteString -> Bool
BS.null ByteString
chunk
        then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else do
          Handle -> ByteString -> IO ()
BS.hPut Handle
dstH ByteString
chunk
          Handle -> Handle -> IO ()
copyLoop Handle
srcH Handle
dstH

-- | Copy M4A file with updated metadata
copyM4AWithMetadata :: OsPath -> OsPath -> Metadata -> Maybe AlbumArt -> Writer ()
copyM4AWithMetadata :: OsPath -> OsPath -> Metadata -> Maybe AlbumArt -> Writer ()
copyM4AWithMetadata OsPath
srcPath OsPath
dstPath Metadata
metadata Maybe AlbumArt
maybeAlbumArt = do
  -- Parse source file to get atom structure
  [AtomInfo]
atoms <- IO [AtomInfo] -> ExceptT WriteError IO [AtomInfo]
forall a. IO a -> ExceptT WriteError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [AtomInfo] -> ExceptT WriteError IO [AtomInfo])
-> IO [AtomInfo] -> ExceptT WriteError IO [AtomInfo]
forall a b. (a -> b) -> a -> b
$ OsPath -> IOMode -> (Handle -> IO [AtomInfo]) -> IO [AtomInfo]
forall r. OsPath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile OsPath
srcPath IOMode
ReadMode Handle -> IO [AtomInfo]
parseTopLevelAtoms

  -- Find moov atom
  case [AtomInfo] -> Maybe (Integer, Word64)
findMoovAtom [AtomInfo]
atoms of
    Maybe (Integer, Word64)
Nothing -> WriteError -> Writer ()
forall a. WriteError -> ExceptT WriteError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (WriteError -> Writer ()) -> WriteError -> Writer ()
forall a b. (a -> b) -> a -> b
$ Text -> WriteError
CorruptedWrite Text
"No moov atom found"
    Just (Integer
moovOffset, Word64
moovSize) -> do
      -- Generate new ilst atom data
      ByteString
ilstData <- Metadata -> Maybe AlbumArt -> Writer ByteString
generateIlstData Metadata
metadata Maybe AlbumArt
maybeAlbumArt

      -- Write to destination
      Either WriteError ()
_ <- IO (Either WriteError ())
-> ExceptT WriteError IO (Either WriteError ())
forall a. IO a -> ExceptT WriteError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either WriteError ())
 -> ExceptT WriteError IO (Either WriteError ()))
-> IO (Either WriteError ())
-> ExceptT WriteError IO (Either WriteError ())
forall a b. (a -> b) -> a -> b
$ OsPath
-> IOMode
-> (Handle -> IO (Either WriteError ()))
-> IO (Either WriteError ())
forall r. OsPath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile OsPath
srcPath IOMode
ReadMode ((Handle -> IO (Either WriteError ()))
 -> IO (Either WriteError ()))
-> (Handle -> IO (Either WriteError ()))
-> IO (Either WriteError ())
forall a b. (a -> b) -> a -> b
$ \Handle
srcHandle -> do
        OsPath
-> IOMode
-> (Handle -> IO (Either WriteError ()))
-> IO (Either WriteError ())
forall r. OsPath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile OsPath
dstPath IOMode
WriteMode ((Handle -> IO (Either WriteError ()))
 -> IO (Either WriteError ()))
-> (Handle -> IO (Either WriteError ()))
-> IO (Either WriteError ())
forall a b. (a -> b) -> a -> b
$ \Handle
dstHandle -> do
          Writer () -> IO (Either WriteError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (Writer () -> IO (Either WriteError ()))
-> Writer () -> IO (Either WriteError ())
forall a b. (a -> b) -> a -> b
$ Handle
-> Handle
-> [AtomInfo]
-> Integer
-> Word64
-> ByteString
-> Writer ()
rewriteM4AFile Handle
srcHandle Handle
dstHandle [AtomInfo]
atoms Integer
moovOffset Word64
moovSize ByteString
ilstData

      () -> Writer ()
forall a. a -> ExceptT WriteError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Simple atom info for tracking during parse
data AtomInfo = AtomInfo
  { AtomInfo -> Integer
aiOffset :: Integer
  , AtomInfo -> Word64
aiSize :: Word64
  , AtomInfo -> ByteString
aiName :: ByteString
  } deriving (Int -> AtomInfo -> ShowS
[AtomInfo] -> ShowS
AtomInfo -> String
(Int -> AtomInfo -> ShowS)
-> (AtomInfo -> String) -> ([AtomInfo] -> ShowS) -> Show AtomInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AtomInfo -> ShowS
showsPrec :: Int -> AtomInfo -> ShowS
$cshow :: AtomInfo -> String
show :: AtomInfo -> String
$cshowList :: [AtomInfo] -> ShowS
showList :: [AtomInfo] -> ShowS
Show)

-- | Parse top-level atoms (simplified, just track positions)
parseTopLevelAtoms :: Handle -> IO [AtomInfo]
parseTopLevelAtoms :: Handle -> IO [AtomInfo]
parseTopLevelAtoms Handle
handle = do
  Integer
fileSize <- Handle -> IO Integer
hFileSize Handle
handle
  Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek Integer
0
  Handle -> Integer -> [AtomInfo] -> IO [AtomInfo]
parseAtomsLoop Handle
handle Integer
fileSize []
  where
    parseAtomsLoop :: Handle -> Integer -> [AtomInfo] -> IO [AtomInfo]
parseAtomsLoop Handle
h Integer
endPos [AtomInfo]
acc = do
      Integer
pos <- Handle -> IO Integer
hTell Handle
h
      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 [AtomInfo] -> IO [AtomInfo]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([AtomInfo] -> IO [AtomInfo]) -> [AtomInfo] -> IO [AtomInfo]
forall a b. (a -> b) -> a -> b
$ [AtomInfo] -> [AtomInfo]
forall a. [a] -> [a]
reverse [AtomInfo]
acc
        else do
          ByteString
header <- Handle -> Int -> IO ByteString
BS.hGet Handle
h Int
8
          if ByteString -> Int
BS.length ByteString
header Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8
            then [AtomInfo] -> IO [AtomInfo]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([AtomInfo] -> IO [AtomInfo]) -> [AtomInfo] -> IO [AtomInfo]
forall a b. (a -> b) -> a -> b
$ [AtomInfo] -> [AtomInfo]
forall a. [a] -> [a]
reverse [AtomInfo]
acc
            else do
              let size32 :: Word32
size32 = ByteString -> Word32
readWord32BE (ByteString -> Word32) -> ByteString -> Word32
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
4 ByteString
header
                  name :: ByteString
name = 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
header

              Word64
actualSize <- if Word32
size32 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
1
                then do
                  ByteString
sizeData <- Handle -> Int -> IO ByteString
BS.hGet Handle
h Int
8
                  Word64 -> IO Word64
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> IO Word64) -> Word64 -> IO Word64
forall a b. (a -> b) -> a -> b
$ ByteString -> Word64
readWord64BE ByteString
sizeData
                else Word64 -> IO Word64
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> IO Word64) -> Word64 -> IO Word64
forall a b. (a -> b) -> a -> b
$ Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size32

              let atomInfo :: AtomInfo
atomInfo = AtomInfo
                    { aiOffset :: Integer
aiOffset = Integer
pos
                    , aiSize :: Word64
aiSize = Word64
actualSize
                    , aiName :: ByteString
aiName = ByteString
name
                    }

              Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek (Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
actualSize)
              Handle -> Integer -> [AtomInfo] -> IO [AtomInfo]
parseAtomsLoop Handle
h Integer
endPos (AtomInfo
atomInfo AtomInfo -> [AtomInfo] -> [AtomInfo]
forall a. a -> [a] -> [a]
: [AtomInfo]
acc)

-- | Find moov atom
findMoovAtom :: [AtomInfo] -> Maybe (Integer, Word64)
findMoovAtom :: [AtomInfo] -> Maybe (Integer, Word64)
findMoovAtom [AtomInfo]
atoms = case (AtomInfo -> Bool) -> [AtomInfo] -> [AtomInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter (\AtomInfo
a -> AtomInfo -> ByteString
aiName AtomInfo
a ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"moov") [AtomInfo]
atoms of
  (AtomInfo
moov:[AtomInfo]
_) -> (Integer, Word64) -> Maybe (Integer, Word64)
forall a. a -> Maybe a
Just (AtomInfo -> Integer
aiOffset AtomInfo
moov, AtomInfo -> Word64
aiSize AtomInfo
moov)
  [] -> Maybe (Integer, Word64)
forall a. Maybe a
Nothing

-- | Rewrite M4A file with new metadata
rewriteM4AFile :: Handle -> Handle -> [AtomInfo] -> Integer -> Word64 -> L.ByteString -> Writer ()
rewriteM4AFile :: Handle
-> Handle
-> [AtomInfo]
-> Integer
-> Word64
-> ByteString
-> Writer ()
rewriteM4AFile Handle
srcHandle Handle
dstHandle [AtomInfo]
atoms Integer
moovOffset Word64
moovSize ByteString
newIlstData = do
  -- Copy all atoms before moov
  IO () -> Writer ()
forall a. IO a -> ExceptT WriteError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Writer ()) -> IO () -> Writer ()
forall a b. (a -> b) -> a -> b
$ Handle -> Handle -> [AtomInfo] -> Integer -> IO ()
copyBeforeMoov Handle
srcHandle Handle
dstHandle [AtomInfo]
atoms Integer
moovOffset

  -- Read and rewrite moov atom with new ilst
  IO () -> Writer ()
forall a. IO a -> ExceptT WriteError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Writer ()) -> IO () -> Writer ()
forall a b. (a -> b) -> a -> b
$ do
    Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
srcHandle SeekMode
AbsoluteSeek Integer
moovOffset
    ByteString
moovData <- Handle -> Int -> IO ByteString
BS.hGet Handle
srcHandle (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
moovSize)

    -- Rebuild moov with new ilst
    let newMoovData :: ByteString
newMoovData = ByteString -> ByteString -> ByteString
rebuildMoovAtom ByteString
moovData ByteString
newIlstData
    Handle -> ByteString -> IO ()
L.hPut Handle
dstHandle ByteString
newMoovData

  -- Copy all atoms after moov
  IO () -> Writer ()
forall a. IO a -> ExceptT WriteError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Writer ()) -> IO () -> Writer ()
forall a b. (a -> b) -> a -> b
$ Handle -> Handle -> Integer -> Word64 -> IO ()
copyAfterMoov Handle
srcHandle Handle
dstHandle Integer
moovOffset Word64
moovSize

-- | Copy atoms before moov
copyBeforeMoov :: Handle -> Handle -> [AtomInfo] -> Integer -> IO ()
copyBeforeMoov :: Handle -> Handle -> [AtomInfo] -> Integer -> IO ()
copyBeforeMoov Handle
srcHandle Handle
dstHandle [AtomInfo]
atoms Integer
moovOffset = do
  Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
srcHandle SeekMode
AbsoluteSeek Integer
0
  let beforeAtoms :: [AtomInfo]
beforeAtoms = (AtomInfo -> Bool) -> [AtomInfo] -> [AtomInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter (\AtomInfo
a -> AtomInfo -> Integer
aiOffset AtomInfo
a Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
moovOffset) [AtomInfo]
atoms
  (AtomInfo -> IO ()) -> [AtomInfo] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> Handle -> AtomInfo -> IO ()
copyAtom Handle
srcHandle Handle
dstHandle) [AtomInfo]
beforeAtoms

-- | Copy atoms after moov
copyAfterMoov :: Handle -> Handle -> Integer -> Word64 -> IO ()
copyAfterMoov :: Handle -> Handle -> Integer -> Word64 -> IO ()
copyAfterMoov Handle
srcHandle Handle
dstHandle Integer
moovOffset Word64
moovSize = do
  let afterOffset :: Integer
afterOffset = Integer
moovOffset Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
moovSize
  Integer
fileSize <- Handle -> IO Integer
hFileSize Handle
srcHandle
  Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
srcHandle SeekMode
AbsoluteSeek Integer
afterOffset

  let remaining :: Integer
remaining = Integer
fileSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
afterOffset
  Handle -> Handle -> Int -> IO ()
copyBytes Handle
srcHandle Handle
dstHandle (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
remaining)

-- | Copy a single atom
copyAtom :: Handle -> Handle -> AtomInfo -> IO ()
copyAtom :: Handle -> Handle -> AtomInfo -> IO ()
copyAtom Handle
srcHandle Handle
dstHandle AtomInfo
atom = do
  Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
srcHandle SeekMode
AbsoluteSeek (AtomInfo -> Integer
aiOffset AtomInfo
atom)
  Handle -> Handle -> Int -> IO ()
copyBytes Handle
srcHandle Handle
dstHandle (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ AtomInfo -> Word64
aiSize AtomInfo
atom)

-- | Copy bytes from one handle to another
copyBytes :: Handle -> Handle -> Int -> IO ()
copyBytes :: Handle -> Handle -> Int -> IO ()
copyBytes Handle
srcHandle Handle
dstHandle Int
count = Int -> IO ()
go Int
count
  where
    go :: Int -> IO ()
go Int
n
      | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise = do
          let chunkSize :: Int
chunkSize = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
65536 Int
n
          ByteString
chunk <- Handle -> Int -> IO ByteString
BS.hGet Handle
srcHandle Int
chunkSize
          Handle -> ByteString -> IO ()
BS.hPut Handle
dstHandle ByteString
chunk
          Int -> IO ()
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
chunk)

-- | Rebuild moov atom with new ilst data
rebuildMoovAtom :: ByteString -> L.ByteString -> L.ByteString
rebuildMoovAtom :: ByteString -> ByteString -> ByteString
rebuildMoovAtom ByteString
oldMoovData ByteString
newIlstData =
  let newIlst :: ByteString
newIlst = ByteString -> ByteString -> ByteString
renderAtom ByteString
"ilst" ByteString
newIlstData
      newMeta :: ByteString
newMeta = ByteString -> ByteString -> ByteString
renderAtom ByteString
"meta" (ByteString -> ByteString
L.fromStrict ByteString
"\0\0\0\0" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString -> ByteString
renderAtom ByteString
"hdlr" ByteString
hdlrData ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
newIlst)
      newUdta :: ByteString
newUdta = ByteString -> ByteString -> ByteString
renderAtom ByteString
"udta" ByteString
newMeta

      -- Parse moov children and filter out any existing udta
      moovContentData :: ByteString
moovContentData = Int -> ByteString -> ByteString
BS.drop Int
8 ByteString
oldMoovData
      childrenWithoutUdta :: ByteString
childrenWithoutUdta = ByteString -> ByteString
filterOutUdta ByteString
moovContentData

      -- Build new moov with filtered children + new udta
      newMoovContent :: ByteString
newMoovContent = ByteString
childrenWithoutUdta ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
newUdta
  in ByteString -> ByteString -> ByteString
renderAtom ByteString
"moov" ByteString
newMoovContent
  where
    hdlrData :: ByteString
hdlrData = ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ [[Word8]] -> [Word8]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [Word8
0,Word8
0,Word8
0,Word8
0, Word8
0,Word8
0,Word8
0,Word8
0]  -- version/flags + reserved
      , (Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum) String
"mdirappl"  -- handler_type + reserved
      , [Word8
0,Word8
0,Word8
0,Word8
0, Word8
0,Word8
0,Word8
0,Word8
0, Word8
0]  -- reserved
      ]

-- | Filter out udta atom from a sequence of atoms
filterOutUdta :: ByteString -> L.ByteString
filterOutUdta :: ByteString -> ByteString
filterOutUdta ByteString
bs = ByteString -> ByteString -> ByteString
go ByteString
bs ByteString
L.empty
  where
    go :: ByteString -> ByteString -> ByteString
go ByteString
remaining ByteString
acc
      | ByteString -> Int
BS.length ByteString
remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8 = ByteString
acc
      | Bool
otherwise =
          let size32 :: Word32
size32 = ByteString -> Word32
readWord32BE (ByteString -> Word32) -> ByteString -> Word32
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
4 ByteString
remaining
              name :: ByteString
name = 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
remaining

              actualSize :: Int
actualSize = if Word32
size32 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
1
                then Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Word64
readWord64BE (ByteString -> Word64) -> ByteString -> Word64
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
8 ByteString
remaining
                else Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size32

              atomData :: ByteString
atomData = ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
actualSize ByteString
remaining
              nextRemaining :: ByteString
nextRemaining = Int -> ByteString -> ByteString
BS.drop Int
actualSize ByteString
remaining

          in if ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"udta"
             then ByteString -> ByteString -> ByteString
go ByteString
nextRemaining ByteString
acc  -- Skip udta atom
             else ByteString -> ByteString -> ByteString
go ByteString
nextRemaining (ByteString
acc ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
atomData)  -- Keep other atoms

-- | Generate ilst atom data with all tags
generateIlstData :: Metadata -> Maybe AlbumArt -> Writer L.ByteString
generateIlstData :: Metadata -> Maybe AlbumArt -> Writer ByteString
generateIlstData Metadata
metadata Maybe AlbumArt
maybeAlbumArt = do
  let tags :: [ByteString]
tags = [[ByteString]] -> [ByteString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ ByteString -> Text -> ByteString
renderTextTag ByteString
"\169nam" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (Metadata -> Maybe Text
title Metadata
metadata)
        , ByteString -> Text -> ByteString
renderTextTag ByteString
"\169ART" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (Metadata -> Maybe Text
artist Metadata
metadata)
        , ByteString -> Text -> ByteString
renderTextTag ByteString
"\169alb" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (Metadata -> Maybe Text
album Metadata
metadata)
        , ByteString -> Text -> ByteString
renderTextTag ByteString
"aART" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (Metadata -> Maybe Text
albumArtist Metadata
metadata)
        , ByteString -> Text -> ByteString
renderTextTag ByteString
"\169day" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (Metadata -> Maybe Text
date Metadata
metadata)
        , ByteString -> Text -> ByteString
renderTextTag ByteString
"\169gen" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (Metadata -> Maybe Text
genre Metadata
metadata)
        , ByteString -> Text -> ByteString
renderTextTag ByteString
"\169cmt" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (Metadata -> Maybe Text
comment Metadata
metadata)
        , ByteString -> Text -> ByteString
renderTextTag ByteString
"\169pub" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (Metadata -> Maybe Text
publisher Metadata
metadata)
        , Maybe ByteString -> [ByteString]
forall a. Maybe a -> [a]
maybeToList (Maybe ByteString -> [ByteString])
-> Maybe ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Int -> Maybe Int -> Maybe ByteString
renderTrackDiskTag ByteString
"trkn" (Metadata -> Maybe Int
trackNumber Metadata
metadata) (Metadata -> Maybe Int
totalTracks Metadata
metadata)
        , Maybe ByteString -> [ByteString]
forall a. Maybe a -> [a]
maybeToList (Maybe ByteString -> [ByteString])
-> Maybe ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Int -> Maybe Int -> Maybe ByteString
renderTrackDiskTag ByteString
"disk" (Metadata -> Maybe Int
discNumber Metadata
metadata) (Metadata -> Maybe Int
totalDiscs Metadata
metadata)
        , AlbumArt -> ByteString
renderCoverTag (AlbumArt -> ByteString) -> [AlbumArt] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AlbumArt -> [AlbumArt]
forall a. Maybe a -> [a]
maybeToList Maybe AlbumArt
maybeAlbumArt
        -- Freeform tags for MusicBrainz-style metadata
        , ByteString -> Text -> ByteString
renderFreeformTag ByteString
"LABEL" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (Metadata -> Maybe Text
recordLabel Metadata
metadata)
        , ByteString -> Text -> ByteString
renderFreeformTag ByteString
"CATALOGNUMBER" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (Metadata -> Maybe Text
catalogNumber Metadata
metadata)
        , ByteString -> Text -> ByteString
renderFreeformTag ByteString
"BARCODE" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (Metadata -> Maybe Text
barcode Metadata
metadata)
        , ByteString -> Text -> ByteString
renderFreeformTag ByteString
"MusicBrainz Album Release Country" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (Metadata -> Maybe Text
releaseCountry Metadata
metadata)
        -- MusicBrainz IDs
        , MusicBrainzIds -> [ByteString]
renderMusicBrainzIds (Metadata -> MusicBrainzIds
musicBrainzIds Metadata
metadata)
        -- Acoustid
        , ByteString -> Text -> ByteString
renderFreeformTag ByteString
"Acoustid Fingerprint" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (Metadata -> Maybe Text
acoustidFingerprint Metadata
metadata)
        , ByteString -> Text -> ByteString
renderFreeformTag ByteString
"Acoustid Id" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (Metadata -> Maybe Text
acoustidId Metadata
metadata)
        ]

  ByteString -> Writer ByteString
forall a. a -> ExceptT WriteError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Writer ByteString)
-> ByteString -> Writer ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat [ByteString]
tags
  where
    renderMusicBrainzIds :: MusicBrainzIds -> [ByteString]
renderMusicBrainzIds MusicBrainzIds
mbids = [[ByteString]] -> [ByteString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ ByteString -> Text -> ByteString
renderFreeformTag ByteString
"MusicBrainz Release Track Id" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (MusicBrainzIds -> Maybe Text
mbTrackId MusicBrainzIds
mbids)
      , ByteString -> Text -> ByteString
renderFreeformTag ByteString
"MusicBrainz Track Id" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (MusicBrainzIds -> Maybe Text
mbRecordingId MusicBrainzIds
mbids)
      , ByteString -> Text -> ByteString
renderFreeformTag ByteString
"MusicBrainz Album Id" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (MusicBrainzIds -> Maybe Text
mbReleaseId MusicBrainzIds
mbids)
      , ByteString -> Text -> ByteString
renderFreeformTag ByteString
"MusicBrainz Release Group Id" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (MusicBrainzIds -> Maybe Text
mbReleaseGroupId MusicBrainzIds
mbids)
      , ByteString -> Text -> ByteString
renderFreeformTag ByteString
"MusicBrainz Artist Id" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (MusicBrainzIds -> Maybe Text
mbArtistId MusicBrainzIds
mbids)
      , ByteString -> Text -> ByteString
renderFreeformTag ByteString
"MusicBrainz Album Artist Id" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (MusicBrainzIds -> Maybe Text
mbAlbumArtistId MusicBrainzIds
mbids)
      , ByteString -> Text -> ByteString
renderFreeformTag ByteString
"MusicBrainz Work Id" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (MusicBrainzIds -> Maybe Text
mbWorkId MusicBrainzIds
mbids)
      , ByteString -> Text -> ByteString
renderFreeformTag ByteString
"MusicBrainz Disc Id" (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (MusicBrainzIds -> Maybe Text
mbDiscId MusicBrainzIds
mbids)
      ]

-- | Render a text tag atom
renderTextTag :: ByteString -> Text -> L.ByteString
renderTextTag :: ByteString -> Text -> ByteString
renderTextTag ByteString
name Text
value =
  let textData :: ByteString
textData = Text -> ByteString
TE.encodeUtf8 Text
value
      dataAtom :: ByteString
dataAtom = Word32 -> ByteString -> ByteString
renderDataAtom Word32
1 ByteString
textData  -- Type 1 = UTF-8
  in ByteString -> ByteString -> ByteString
renderAtom ByteString
name ByteString
dataAtom

-- | Render track/disk number tag
renderTrackDiskTag :: ByteString -> Maybe Int -> Maybe Int -> Maybe L.ByteString
renderTrackDiskTag :: ByteString -> Maybe Int -> Maybe Int -> Maybe ByteString
renderTrackDiskTag ByteString
name (Just Int
current) Maybe Int
maybeTotal =
  let total :: Int
total = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
maybeTotal
      trackData :: ByteString
trackData = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ do
        Word16 -> Put
putWord16be Word16
0  -- reserved
        Word16 -> Put
putWord16be (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
current)
        Word16 -> Put
putWord16be (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
total)
        Word16 -> Put
putWord16be Word16
0  -- reserved
      dataAtom :: ByteString
dataAtom = Word32 -> ByteString -> ByteString
renderDataAtom Word32
0 (ByteString -> ByteString
L.toStrict ByteString
trackData)  -- Type 0 = implicit
  in ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ByteString
renderAtom ByteString
name ByteString
dataAtom
renderTrackDiskTag ByteString
_ Maybe Int
Nothing Maybe Int
_ = Maybe ByteString
forall a. Maybe a
Nothing

-- | Render cover art tag
renderCoverTag :: AlbumArt -> L.ByteString
renderCoverTag :: AlbumArt -> ByteString
renderCoverTag AlbumArt
art =
  let imageType :: Word32
imageType = case AlbumArt -> Text
albumArtMimeType AlbumArt
art of
        Text
"image/jpeg" -> Word32
13
        Text
"image/png" -> Word32
14
        Text
"image/bmp" -> Word32
27
        Text
_ -> Word32
13  -- Default to JPEG
      dataAtom :: ByteString
dataAtom = Word32 -> ByteString -> ByteString
renderDataAtom Word32
imageType (AlbumArt -> ByteString
albumArtData AlbumArt
art)
  in ByteString -> ByteString -> ByteString
renderAtom ByteString
"covr" ByteString
dataAtom

-- | Render freeform tag (----:com.apple.iTunes:NAME)
renderFreeformTag :: ByteString -> Text -> L.ByteString
renderFreeformTag :: ByteString -> Text -> ByteString
renderFreeformTag ByteString
name Text
value =
  let mean :: ByteString
mean = ByteString
"com.apple.iTunes"
      meanAtom :: ByteString
meanAtom = ByteString -> ByteString -> ByteString
renderAtom ByteString
"mean" (Put -> ByteString
runPut (Word32 -> Put
putWord32be Word32
0) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
L.fromStrict ByteString
mean)
      nameAtom :: ByteString
nameAtom = ByteString -> ByteString -> ByteString
renderAtom ByteString
"name" (Put -> ByteString
runPut (Word32 -> Put
putWord32be Word32
0) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
L.fromStrict ByteString
name)
      textData :: ByteString
textData = Text -> ByteString
TE.encodeUtf8 Text
value
      dataAtom :: ByteString
dataAtom = Word32 -> ByteString -> ByteString
renderDataAtom Word32
1 ByteString
textData  -- Type 1 = UTF-8
  in ByteString -> ByteString -> ByteString
renderAtom ByteString
"----" (ByteString
meanAtom ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
nameAtom ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
dataAtom)

-- | Render a data atom
-- Structure: [size:4]['data':4][version/flags:4][reserved?:4][data...]
-- Empirically, there seem to be 16 bytes before data starts (not 12)
renderDataAtom :: Word32 -> ByteString -> L.ByteString
renderDataAtom :: Word32 -> ByteString -> ByteString
renderDataAtom Word32
dataType ByteString
content =
  let header :: ByteString
header = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ do
        Word32 -> Put
putWord32be Word32
dataType  -- version/flags with type
        Word32 -> Put
putWord32be Word32
0         -- Appears to be a reserved/locale field
  in ByteString -> ByteString -> ByteString
renderAtom ByteString
"data" (ByteString
header ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
L.fromStrict ByteString
content)

-- | Render an atom with name and data
renderAtom :: ByteString -> L.ByteString -> L.ByteString
renderAtom :: ByteString -> ByteString -> ByteString
renderAtom ByteString
name ByteString
content =
  let size :: Int64
size = Int64
8 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ ByteString -> Int64
L.length ByteString
content
      header :: ByteString
header = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ do
        Word32 -> Put
putWord32be (Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
size)
        ByteString -> Put
putByteString ByteString
name
  in ByteString
header ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
content

-- Helper functions
readWord32BE :: ByteString -> Word32
readWord32BE :: ByteString -> Word32
readWord32BE ByteString
bs =
  let b0 :: Word32
b0 = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bs Int
0) :: Word32
      b1 :: Word32
b1 = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bs Int
1) :: Word32
      b2 :: Word32
b2 = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bs Int
2) :: Word32
      b3 :: Word32
b3 = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bs Int
3) :: Word32
  in (Word32
b0 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
24) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word32
b1 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
16) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word32
b2 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
b3

readWord64BE :: ByteString -> Word64
readWord64BE :: ByteString -> Word64
readWord64BE ByteString
bs =
  let b0 :: Word64
b0 = Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bs Int
0) :: Word64
      b1 :: Word64
b1 = Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bs Int
1) :: Word64
      b2 :: Word64
b2 = Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bs Int
2) :: Word64
      b3 :: Word64
b3 = Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bs Int
3) :: Word64
      b4 :: Word64
b4 = Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bs Int
4) :: Word64
      b5 :: Word64
b5 = Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bs Int
5) :: Word64
      b6 :: Word64
b6 = Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bs Int
6) :: Word64
      b7 :: Word64
b7 = Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bs Int
7) :: Word64
  in (Word64
b0 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
56) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
b1 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
48) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
b2 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
40) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
b3 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
32) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|.
     (Word64
b4 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
24) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
b5 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
16) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
b6 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
b7