{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE QuasiQuotes #-}

module Monatone.FLAC.Writer
  ( writeFLACMetadata
  , WriteError(..)
  , Writer
  ) where

import Control.Exception (catch, IOException)
import Control.Monad.Except (ExceptT, throwError, runExceptT)
import Control.Monad.IO.Class (liftIO)
import Data.Binary.Get
import Data.Binary.Put
import Data.Bits ((.|.), shiftL, shiftR, (.&.))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
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 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

-- | Buffer size for file operations (64KB)
bufferSize :: Int
bufferSize :: Int
bufferSize = Int
65536

-- | Write metadata to FLAC file incrementally
-- Takes optional AlbumArt separately since Metadata only stores AlbumArtInfo
writeFLACMetadata :: Metadata -> Maybe AlbumArt -> OsPath -> Writer ()
writeFLACMetadata :: Metadata -> Maybe AlbumArt -> OsPath -> Writer ()
writeFLACMetadata Metadata
metadata Maybe AlbumArt
maybeAlbumArt OsPath
filePath = do
  -- Open file in read/write mode
  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
$ OsPath
-> IOMode
-> (Handle -> IO (Either WriteError ()))
-> IO (Either WriteError ())
forall r. OsPath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile OsPath
filePath IOMode
ReadWriteMode ((Handle -> IO (Either WriteError ()))
 -> IO (Either WriteError ()))
-> (Handle -> IO (Either WriteError ()))
-> IO (Either WriteError ())
forall a b. (a -> b) -> a -> b
$ \Handle
handle -> 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
$ Metadata -> Maybe AlbumArt -> Handle -> Writer ()
writeFLACHandleIncremental Metadata
metadata Maybe AlbumArt
maybeAlbumArt Handle
handle
  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)

-- | Write FLAC metadata using a file handle incrementally
writeFLACHandleIncremental :: Metadata -> Maybe AlbumArt -> Handle -> Writer ()
writeFLACHandleIncremental :: Metadata -> Maybe AlbumArt -> Handle -> Writer ()
writeFLACHandleIncremental Metadata
metadata Maybe AlbumArt
maybeAlbumArt Handle
handle = do
  -- Verify FLAC signature
  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 -> SeekMode -> Integer -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek Integer
0
  ByteString
sig <- IO ByteString -> ExceptT WriteError IO ByteString
forall a. IO a -> ExceptT WriteError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ExceptT WriteError IO ByteString)
-> IO ByteString -> ExceptT WriteError IO ByteString
forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO ByteString
BS.hGet Handle
handle Int
4
  case ByteString -> [Word8]
BS.unpack ByteString
sig of
    [Word8
0x66, Word8
0x4C, Word8
0x61, Word8
0x43] -> () -> Writer ()
forall a. a -> ExceptT WriteError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()  -- "fLaC"
    [Word8]
_ -> 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
"Invalid FLAC signature"

  -- Extract original STREAMINFO block for preservation (it's always first, 34 bytes)
  ByteString
streamInfoHeader <- IO ByteString -> ExceptT WriteError IO ByteString
forall a. IO a -> ExceptT WriteError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ExceptT WriteError IO ByteString)
-> IO ByteString -> ExceptT WriteError IO ByteString
forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO ByteString
BS.hGet Handle
handle Int
4
  ByteString
streamInfoData <- IO ByteString -> ExceptT WriteError IO ByteString
forall a. IO a -> ExceptT WriteError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ExceptT WriteError IO ByteString)
-> IO ByteString -> ExceptT WriteError IO ByteString
forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO ByteString
BS.hGet Handle
handle Int
34
  let originalStreamInfo :: ByteString
originalStreamInfo = ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ByteString
BS.append ByteString
streamInfoHeader ByteString
streamInfoData

  -- Find where the audio data starts
  Int
audioDataOffset <- Handle -> Int -> Writer Int
findAudioDataOffsetHandle Handle
handle Int
4  -- Start after "fLaC"

  -- Generate new metadata blocks with preserved STREAMINFO
  ByteString
newMetadataBlocks <- Metadata -> Maybe AlbumArt -> ByteString -> Writer ByteString
generateMetadataBlocks Metadata
metadata Maybe AlbumArt
maybeAlbumArt ByteString
originalStreamInfo
  let newMetadataSize :: Int
newMetadataSize = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
L.length ByteString
newMetadataBlocks
  
  -- Get file size
  Integer
_ <- IO Integer -> ExceptT WriteError IO Integer
forall a. IO a -> ExceptT WriteError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Integer -> ExceptT WriteError IO Integer)
-> IO Integer -> ExceptT WriteError IO Integer
forall a b. (a -> b) -> a -> b
$ Handle -> IO Integer
hFileSize Handle
handle
  
  -- Calculate size difference (new metadata vs old metadata)
  let oldMetadataSize :: Int
oldMetadataSize = Int
audioDataOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4  -- Subtract "fLaC" signature
  let sizeDiff :: Int
sizeDiff = Int
newMetadataSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
oldMetadataSize
  
  if Int
sizeDiff Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then do
    -- Same size, just overwrite metadata blocks
    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
handle SeekMode
AbsoluteSeek Integer
4  -- Position after "fLaC"
      Handle -> ByteString -> IO ()
L.hPut Handle
handle ByteString
newMetadataBlocks
  else if Int
sizeDiff Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then do
    -- Need to insert bytes
    Handle -> Int -> Int -> Writer ()
insertBytesInFile Handle
handle Int
sizeDiff Int
audioDataOffset
    -- Write new metadata blocks
    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
handle SeekMode
AbsoluteSeek Integer
4
      Handle -> ByteString -> IO ()
L.hPut Handle
handle ByteString
newMetadataBlocks
  else do
    -- Need to delete bytes
    let bytesToDelete :: Int
bytesToDelete = Int -> Int
forall a. Num a => a -> a
negate Int
sizeDiff
    -- Write new metadata first
    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
handle SeekMode
AbsoluteSeek Integer
4
      Handle -> ByteString -> IO ()
L.hPut Handle
handle ByteString
newMetadataBlocks
    -- Then delete extra space
    Handle -> Int -> Int -> Writer ()
deleteBytesInFile Handle
handle Int
bytesToDelete (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
newMetadataSize)

-- | Find where audio data starts by parsing metadata blocks
findAudioDataOffsetHandle :: Handle -> Int -> Writer Int
findAudioDataOffsetHandle :: Handle -> Int -> Writer Int
findAudioDataOffsetHandle Handle
handle Int
currentOffset = do
  -- Seek to current position
  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 -> SeekMode -> Integer -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
currentOffset)
  
  -- Read block header (4 bytes)
  ByteString
headerBytes <- IO ByteString -> ExceptT WriteError IO ByteString
forall a. IO a -> ExceptT WriteError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ExceptT WriteError IO ByteString)
-> IO ByteString -> ExceptT WriteError IO ByteString
forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO ByteString
BS.hGet Handle
handle Int
4
  if ByteString -> Int
BS.length ByteString
headerBytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4 then
    Int -> Writer Int
forall a. a -> ExceptT WriteError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
currentOffset
  else do
    let header :: BlockHeader
header = Get BlockHeader -> ByteString -> BlockHeader
forall a. Get a -> ByteString -> a
runGet Get BlockHeader
parseBlockHeader (ByteString -> ByteString
L.fromStrict ByteString
headerBytes)
    let blockSize :: Int
blockSize = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (BlockHeader -> Word32
blockLength BlockHeader
header)
    let nextOffset :: Int
nextOffset = Int
currentOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
blockSize
    
    if BlockHeader -> Bool
isLast BlockHeader
header
      then Int -> Writer Int
forall a. a -> ExceptT WriteError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
nextOffset  -- This was the last metadata block
      else Handle -> Int -> Writer Int
findAudioDataOffsetHandle Handle
handle Int
nextOffset

-- | Insert bytes into file at given offset
insertBytesInFile :: Handle -> Int -> Int -> Writer ()
insertBytesInFile :: Handle -> Int -> Int -> Writer ()
insertBytesInFile Handle
handle Int
size Int
offset = do
  -- Get current file size
  Integer
fileSize <- IO Integer -> ExceptT WriteError IO Integer
forall a. IO a -> ExceptT WriteError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Integer -> ExceptT WriteError IO Integer)
-> IO Integer -> ExceptT WriteError IO Integer
forall a b. (a -> b) -> a -> b
$ Handle -> IO Integer
hFileSize Handle
handle
  let moveSize :: Integer
moveSize = Integer
fileSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset
  
  if Integer
moveSize Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then
    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
"Invalid offset for insert"
  else do
    -- First, extend the file
    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 -> Integer -> IO ()
hSetFileSize Handle
handle (Integer
fileSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size)
    
    -- Move data from offset to offset+size, working backwards
    Handle -> Integer -> Integer -> Integer -> Writer ()
moveDataBackwards Handle
handle (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset) (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size) Integer
moveSize

-- | Delete bytes from file at given offset  
deleteBytesInFile :: Handle -> Int -> Int -> Writer ()
deleteBytesInFile :: Handle -> Int -> Int -> Writer ()
deleteBytesInFile Handle
handle Int
size Int
offset = do
  -- Get current file size
  Integer
fileSize <- IO Integer -> ExceptT WriteError IO Integer
forall a. IO a -> ExceptT WriteError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Integer -> ExceptT WriteError IO Integer)
-> IO Integer -> ExceptT WriteError IO Integer
forall a b. (a -> b) -> a -> b
$ Handle -> IO Integer
hFileSize Handle
handle
  let moveSize :: Integer
moveSize = Integer
fileSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size
  
  if Integer
moveSize Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then
    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
"Invalid size/offset for delete"
  else do
    -- Move data from offset+size to offset
    Handle -> Integer -> Integer -> Integer -> Writer ()
moveDataForwards Handle
handle (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size) (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset) Integer
moveSize
    
    -- Truncate the file
    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 -> Integer -> IO ()
hSetFileSize Handle
handle (Integer
fileSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size)

-- | Move data backwards in file (for insertions)
moveDataBackwards :: Handle -> Integer -> Integer -> Integer -> Writer ()
moveDataBackwards :: Handle -> Integer -> Integer -> Integer -> Writer ()
moveDataBackwards Handle
handle Integer
src Integer
dest Integer
count = do
  let go :: Integer -> IO ()
go Integer
remaining' = do
        if Integer
remaining' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 then
          () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else do
          let chunkSize :: Integer
chunkSize = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bufferSize) Integer
remaining'
          -- Read from end of source region
          Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek (Integer
src Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
remaining' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
chunkSize)
          ByteString
chunk <- Handle -> Int -> IO ByteString
BS.hGet Handle
handle (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
chunkSize)
          -- Write to end of dest region
          Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek (Integer
dest Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
remaining' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
chunkSize)
          Handle -> ByteString -> IO ()
BS.hPut Handle
handle ByteString
chunk
          Integer -> IO ()
go (Integer
remaining' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
chunkSize)
  
  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
$ Integer -> IO ()
go Integer
count

-- | Move data forwards in file (for deletions)
moveDataForwards :: Handle -> Integer -> Integer -> Integer -> Writer ()
moveDataForwards :: Handle -> Integer -> Integer -> Integer -> Writer ()
moveDataForwards Handle
handle Integer
src Integer
dest Integer
count = do
  let go :: Integer -> IO ()
go Integer
moved = do
        if Integer
moved Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
count then
          () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else do
          let chunkSize :: Integer
chunkSize = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bufferSize) (Integer
count Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
moved)
          -- Read from source
          Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek (Integer
src Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
moved)
          ByteString
chunk <- Handle -> Int -> IO ByteString
BS.hGet Handle
handle (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
chunkSize)
          -- Write to dest
          Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek (Integer
dest Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
moved)
          Handle -> ByteString -> IO ()
BS.hPut Handle
handle ByteString
chunk
          Integer -> IO ()
go (Integer
moved Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
chunkSize)
  
  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
$ Integer -> IO ()
go Integer
0

-- | FLAC metadata block header
data BlockHeader = BlockHeader
  { BlockHeader -> Bool
isLast :: Bool
  , BlockHeader -> Word8
blockType :: Word8
  , BlockHeader -> Word32
blockLength :: Word32
  } deriving (Int -> BlockHeader -> ShowS
[BlockHeader] -> ShowS
BlockHeader -> String
(Int -> BlockHeader -> ShowS)
-> (BlockHeader -> String)
-> ([BlockHeader] -> ShowS)
-> Show BlockHeader
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BlockHeader -> ShowS
showsPrec :: Int -> BlockHeader -> ShowS
$cshow :: BlockHeader -> String
show :: BlockHeader -> String
$cshowList :: [BlockHeader] -> ShowS
showList :: [BlockHeader] -> ShowS
Show)

-- | Parse FLAC metadata block header
parseBlockHeader :: Get BlockHeader
parseBlockHeader :: Get BlockHeader
parseBlockHeader = do
  Word8
firstByte <- Get Word8
getWord8
  let lastFlag :: Bool
lastFlag = (Word8
firstByte Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x80) Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0
  let bType :: Word8
bType = Word8
firstByte Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x7F
  
  -- Block length is 24 bits
  Word8
b1 <- Get Word8
getWord8
  Word8
b2 <- Get Word8
getWord8
  Word8
b3 <- Get Word8
getWord8
  let len :: Word32
len = (Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b1 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
16) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. 
            (Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b2 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. 
            Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b3
  
  BlockHeader -> Get BlockHeader
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockHeader -> Get BlockHeader) -> BlockHeader -> Get BlockHeader
forall a b. (a -> b) -> a -> b
$ Bool -> Word8 -> Word32 -> BlockHeader
BlockHeader Bool
lastFlag Word8
bType Word32
len

-- | Extract the original STREAMINFO block (already read from handle)
_extractStreamInfoBlock :: L.ByteString -> Writer L.ByteString
_extractStreamInfoBlock :: ByteString -> Writer ByteString
_extractStreamInfoBlock ByteString
blockData = do
  if ByteString -> Int64
L.length ByteString
blockData Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
38  -- 4 byte header + 34 byte STREAMINFO
    then WriteError -> Writer ByteString
forall a. WriteError -> ExceptT WriteError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (WriteError -> Writer ByteString)
-> WriteError -> Writer ByteString
forall a b. (a -> b) -> a -> b
$ Text -> WriteError
CorruptedWrite Text
"File too small for STREAMINFO block"
    else 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
$ Int64 -> ByteString -> ByteString
L.take Int64
38 ByteString
blockData  -- Include header + data

-- | Generate new metadata blocks
generateMetadataBlocks :: Metadata -> Maybe AlbumArt -> L.ByteString -> Writer L.ByteString
generateMetadataBlocks :: Metadata -> Maybe AlbumArt -> ByteString -> Writer ByteString
generateMetadataBlocks Metadata
metadata Maybe AlbumArt
maybeAlbumArt ByteString
originalStreamInfo = do
  -- Generate Vorbis comment block with metadata
  ByteString
vorbisBlock <- Metadata -> Bool -> Writer ByteString
generateVorbisCommentBlock Metadata
metadata Bool
False

  -- Mark STREAMINFO as not-last (clear the last-block flag)
  let streamInfoNotLast :: ByteString
streamInfoNotLast = case ByteString -> [Word8]
L.unpack ByteString
originalStreamInfo of
        (Word8
firstByte:[Word8]
rest) -> [Word8] -> ByteString
L.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Word8
firstByte Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x7F) Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
rest  -- Clear the 0x80 bit
        [Word8]
_ -> ByteString
originalStreamInfo

  -- Generate Picture block if album art is provided
  case Maybe AlbumArt
maybeAlbumArt of
    Maybe AlbumArt
Nothing -> do
      -- Mark Vorbis comment as last block
      let vorbisBlockLast :: ByteString
vorbisBlockLast = case ByteString -> [Word8]
L.unpack ByteString
vorbisBlock of
            (Word8
firstByte:[Word8]
rest) -> [Word8] -> ByteString
L.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Word8
firstByte Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
0x80) Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
rest  -- Set the 0x80 bit
            [Word8]
_ -> ByteString
vorbisBlock
      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
streamInfoNotLast ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
vorbisBlockLast

    Just AlbumArt
albumArt -> do
      -- Generate Picture block
      ByteString
pictureBlock <- AlbumArt -> Bool -> Writer ByteString
generatePictureBlock AlbumArt
albumArt Bool
True

      -- Mark Vorbis comment as not-last
      let vorbisBlockNotLast :: ByteString
vorbisBlockNotLast = case ByteString -> [Word8]
L.unpack ByteString
vorbisBlock of
            (Word8
firstByte:[Word8]
rest) -> [Word8] -> ByteString
L.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Word8
firstByte Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x7F) Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
rest  -- Clear the 0x80 bit
            [Word8]
_ -> ByteString
vorbisBlock

      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
streamInfoNotLast ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
vorbisBlockNotLast ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
pictureBlock

-- | Generate Vorbis comment block
generateVorbisCommentBlock :: Metadata -> Bool -> Writer L.ByteString
generateVorbisCommentBlock :: Metadata -> Bool -> Writer ByteString
generateVorbisCommentBlock Metadata
metadata Bool
isLastBlock = do
  -- Create vendor string
  let vendor :: Text
vendor = Text
"Monatone 0.1.0.0"
  let vendorBytes :: ByteString
vendorBytes = Text -> ByteString
TE.encodeUtf8 Text
vendor
  let vendorLenBytes :: ByteString
vendorLenBytes = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
vendorBytes
  
  -- Create comment list
  [(Text, Text)]
comments <- Metadata -> Writer [(Text, Text)]
generateVorbisComments Metadata
metadata
  let commentCount :: Int
commentCount = [(Text, Text)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Text)]
comments
  let commentCountBytes :: ByteString
commentCountBytes = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
commentCount
  
  -- Encode each comment
  let encodeComment :: (Text, Text) -> ByteString
encodeComment (Text
key, Text
value) = 
        let text :: Text
text = Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
value
            textBytes :: ByteString
textBytes = Text -> ByteString
TE.encodeUtf8 Text
text
            lenBytes :: ByteString
lenBytes = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
textBytes
        in ByteString
lenBytes ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
L.fromStrict ByteString
textBytes
  
  let encodedComments :: ByteString
encodedComments = [ByteString] -> ByteString
L.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> ByteString) -> [(Text, Text)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> ByteString
encodeComment [(Text, Text)]
comments
  
  -- Build complete Vorbis comment data
  let vorbisData :: ByteString
vorbisData = ByteString
vendorLenBytes ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
L.fromStrict ByteString
vendorBytes ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> 
                  ByteString
commentCountBytes ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
encodedComments
  
  -- Create block header
  let blockLen :: Word32
blockLen = Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word32) -> Int64 -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
L.length ByteString
vorbisData :: Word32
  let headerByte :: Word8
headerByte = if Bool
isLastBlock then Word8
0x84 else Word8
0x04  -- Block type 4 = Vorbis comment
  let header :: ByteString
header = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ do
        Word8 -> Put
putWord8 Word8
headerByte
        -- Write 24-bit length
        Word8 -> Put
putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ (Word32
blockLen Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF
        Word8 -> Put
putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ (Word32
blockLen Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
8) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF
        Word8 -> Put
putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
blockLen Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF
  
  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
header ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
vorbisData

-- | Generate Vorbis comments from metadata
generateVorbisComments :: Metadata -> Writer [(Text, Text)]
generateVorbisComments :: Metadata -> Writer [(Text, Text)]
generateVorbisComments Metadata
metadata = do
  let comments :: [a]
comments = []
  
  -- Add standard tags
  let comments1 :: [(Text, Text)]
comments1 = case Metadata -> Maybe Text
title Metadata
metadata of
        Just Text
t -> (Text
"TITLE", Text
t) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
forall a. [a]
comments
        Maybe Text
Nothing -> [(Text, Text)]
forall a. [a]
comments
  
  let comments2 :: [(Text, Text)]
comments2 = case Metadata -> Maybe Text
artist Metadata
metadata of
        Just Text
a -> (Text
"ARTIST", Text
a) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
comments1
        Maybe Text
Nothing -> [(Text, Text)]
comments1
  
  let comments3 :: [(Text, Text)]
comments3 = case Metadata -> Maybe Text
album Metadata
metadata of
        Just Text
a -> (Text
"ALBUM", Text
a) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
comments2
        Maybe Text
Nothing -> [(Text, Text)]
comments2
  
  let comments4 :: [(Text, Text)]
comments4 = case Metadata -> Maybe Text
albumArtist Metadata
metadata of
        Just Text
aa -> (Text
"ALBUMARTIST", Text
aa) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
comments3
        Maybe Text
Nothing -> [(Text, Text)]
comments3
  
  let comments5 :: [(Text, Text)]
comments5 = case Metadata -> Maybe Int
trackNumber Metadata
metadata of
        Just Int
n -> (Text
"TRACKNUMBER", String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
n) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
comments4
        Maybe Int
Nothing -> [(Text, Text)]
comments4
  
  let comments6 :: [(Text, Text)]
comments6 = case Metadata -> Maybe Int
discNumber Metadata
metadata of
        Just Int
n -> (Text
"DISCNUMBER", String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
n) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
comments5
        Maybe Int
Nothing -> [(Text, Text)]
comments5
  
  let comments7 :: [(Text, Text)]
comments7 = case Metadata -> Maybe Int
year Metadata
metadata of
        Just Int
y -> (Text
"DATE", String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
y) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
comments6
        Maybe Int
Nothing -> [(Text, Text)]
comments6
  
  let comments8 :: [(Text, Text)]
comments8 = case Metadata -> Maybe Text
genre Metadata
metadata of
        Just Text
g -> (Text
"GENRE", Text
g) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
comments7
        Maybe Text
Nothing -> [(Text, Text)]
comments7
  
  let comments9 :: [(Text, Text)]
comments9 = case Metadata -> Maybe Text
comment Metadata
metadata of
        Just Text
c -> (Text
"COMMENT", Text
c) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
comments8
        Maybe Text
Nothing -> [(Text, Text)]
comments8
  
  let comments10 :: [(Text, Text)]
comments10 = case Metadata -> Maybe Text
publisher Metadata
metadata of
        Just Text
p -> (Text
"PUBLISHER", Text
p) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
comments9
        Maybe Text
Nothing -> [(Text, Text)]
comments9
  
  -- Add MusicBrainz IDs
  let mbIds :: MusicBrainzIds
mbIds = Metadata -> MusicBrainzIds
musicBrainzIds Metadata
metadata
  let comments11 :: [(Text, Text)]
comments11 = case MusicBrainzIds -> Maybe Text
mbRecordingId MusicBrainzIds
mbIds of
        Just Text
mbId -> (Text
"MUSICBRAINZ_TRACKID", Text
mbId) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
comments10
        Maybe Text
Nothing -> [(Text, Text)]
comments10
  
  let comments12 :: [(Text, Text)]
comments12 = case MusicBrainzIds -> Maybe Text
mbReleaseId MusicBrainzIds
mbIds of
        Just Text
mbId -> (Text
"MUSICBRAINZ_ALBUMID", Text
mbId) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
comments11
        Maybe Text
Nothing -> [(Text, Text)]
comments11
  
  let comments13 :: [(Text, Text)]
comments13 = case MusicBrainzIds -> Maybe Text
mbArtistId MusicBrainzIds
mbIds of
        Just Text
mbId -> (Text
"MUSICBRAINZ_ARTISTID", Text
mbId) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
comments12
        Maybe Text
Nothing -> [(Text, Text)]
comments12
  
  let comments14 :: [(Text, Text)]
comments14 = case MusicBrainzIds -> Maybe Text
mbAlbumArtistId MusicBrainzIds
mbIds of
        Just Text
mbId -> (Text
"MUSICBRAINZ_ALBUMARTISTID", Text
mbId) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
comments13
        Maybe Text
Nothing -> [(Text, Text)]
comments13
  
  let comments15 :: [(Text, Text)]
comments15 = case MusicBrainzIds -> Maybe Text
mbReleaseGroupId MusicBrainzIds
mbIds of
        Just Text
mbId -> (Text
"MUSICBRAINZ_RELEASEGROUPID", Text
mbId) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
comments14
        Maybe Text
Nothing -> [(Text, Text)]
comments14

  -- Add additional metadata fields
  let comments16 :: [(Text, Text)]
comments16 = case Metadata -> Maybe Text
date Metadata
metadata of
        Just Text
d -> (Text
"DATE", Text
d) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
comments15
        Maybe Text
Nothing -> [(Text, Text)]
comments15

  let comments17 :: [(Text, Text)]
comments17 = case Metadata -> Maybe Text
barcode Metadata
metadata of
        Just Text
b -> (Text
"BARCODE", Text
b) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
comments16
        Maybe Text
Nothing -> [(Text, Text)]
comments16

  let comments18 :: [(Text, Text)]
comments18 = case Metadata -> Maybe Text
catalogNumber Metadata
metadata of
        Just Text
cn -> (Text
"CATALOGNUMBER", Text
cn) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
comments17
        Maybe Text
Nothing -> [(Text, Text)]
comments17

  let comments19 :: [(Text, Text)]
comments19 = case Metadata -> Maybe Text
recordLabel Metadata
metadata of
        Just Text
rl -> (Text
"LABEL", Text
rl) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
comments18
        Maybe Text
Nothing -> [(Text, Text)]
comments18

  let comments20 :: [(Text, Text)]
comments20 = case Metadata -> Maybe Text
releaseCountry Metadata
metadata of
        Just Text
rc -> (Text
"RELEASECOUNTRY", Text
rc) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
comments19
        Maybe Text
Nothing -> [(Text, Text)]
comments19

  let comments21 :: [(Text, Text)]
comments21 = case Metadata -> Maybe Text
releaseStatus Metadata
metadata of
        Just Text
rs -> (Text
"RELEASESTATUS", Text
rs) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
comments20
        Maybe Text
Nothing -> [(Text, Text)]
comments20

  let comments22 :: [(Text, Text)]
comments22 = case Metadata -> Maybe Text
releaseType Metadata
metadata of
        Just Text
rt -> (Text
"RELEASETYPE", Text
rt) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
comments21
        Maybe Text
Nothing -> [(Text, Text)]
comments21

  [(Text, Text)] -> Writer [(Text, Text)]
forall a. a -> ExceptT WriteError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Text, Text)]
comments22

-- | Generate Picture block for album art
generatePictureBlock :: AlbumArt -> Bool -> Writer L.ByteString
generatePictureBlock :: AlbumArt -> Bool -> Writer ByteString
generatePictureBlock AlbumArt
art Bool
isLastBlock = do
  let mimeBytes :: ByteString
mimeBytes = Text -> ByteString
TE.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ AlbumArt -> Text
albumArtMimeType AlbumArt
art
      descBytes :: ByteString
descBytes = Text -> ByteString
TE.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ AlbumArt -> Text
albumArtDescription AlbumArt
art
      imageData :: ByteString
imageData = AlbumArt -> ByteString
albumArtData AlbumArt
art

      -- Build picture data according to FLAC spec
      pictureData :: ByteString
pictureData = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ do
        Word32 -> Put
putWord32be (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word32) -> Word8 -> Word32
forall a b. (a -> b) -> a -> b
$ AlbumArt -> Word8
albumArtPictureType AlbumArt
art  -- Picture type
        Word32 -> Put
putWord32be (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
mimeBytes      -- MIME type length
        ByteString -> Put
putByteString ByteString
mimeBytes                               -- MIME type
        Word32 -> Put
putWord32be (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
descBytes      -- Description length
        ByteString -> Put
putByteString ByteString
descBytes                               -- Description
        Word32 -> Put
putWord32be Word32
0                                         -- Width (0 = unknown)
        Word32 -> Put
putWord32be Word32
0                                         -- Height (0 = unknown)
        Word32 -> Put
putWord32be Word32
0                                         -- Color depth (0 = unknown)
        Word32 -> Put
putWord32be Word32
0                                         -- Number of colors (0 = unknown)
        Word32 -> Put
putWord32be (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
imageData      -- Picture data length
        ByteString -> Put
putByteString ByteString
imageData                               -- Picture data

      blockLen :: Word32
blockLen = Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word32) -> Int64 -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
L.length ByteString
pictureData :: Word32
      headerByte :: Word8
headerByte = if Bool
isLastBlock then Word8
0x86 else Word8
0x06  -- Block type 6 = Picture

      -- Build block header
      header :: ByteString
header = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ do
        Word8 -> Put
putWord8 Word8
headerByte
        -- Write 24-bit length
        Word8 -> Put
putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ (Word32
blockLen Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF
        Word8 -> Put
putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ (Word32
blockLen Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
8) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF
        Word8 -> Put
putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
blockLen Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF

  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
header ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
pictureData