Writer.hs

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

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

import Control.Applicative ((<|>))
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 qualified Data.HashMap.Strict as HM
import Data.Maybe (fromMaybe, listToMaybe, 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 (Show, 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 -> AlbumArtUpdate -> OsPath -> Writer ()
writeM4AMetadata metadata artUpdate filePath = do
  result <- liftIO $ tryIO $ do
    -- Create temp file
    withSystemTempFile "monatone-m4a.tmp" $ \tmpPath tmpHandle -> do
      hClose tmpHandle  -- Close it so we can use withBinaryFile
      tmpOsPath <- encodeFS tmpPath

      -- Copy file with updated metadata
      runExceptT $ do
        copyM4AWithMetadata filePath tmpOsPath metadata artUpdate
        -- Copy temp file back to original
        liftIO $ copyFileContents tmpOsPath filePath

  case result of
    Left (e :: IOException) -> throwError $ WriteIOError $ T.pack $ show e
    Right (Left err) -> throwError err
    Right (Right ()) -> return ()
  where
    tryIO :: IO a -> IO (Either IOException a)
    tryIO action = catch (Right <$> action) (return . Left)

-- | Copy file contents
copyFileContents :: OsPath -> OsPath -> IO ()
copyFileContents src dst = do
  withBinaryFile src ReadMode $ \srcHandle -> do
    withBinaryFile dst WriteMode $ \dstHandle -> do
      copyLoop srcHandle dstHandle
  where
    copyLoop srcH dstH = do
      chunk <- BS.hGet srcH 65536
      if BS.null chunk
        then return ()
        else do
          BS.hPut dstH chunk
          copyLoop srcH dstH

-- | Copy M4A file with updated metadata
copyM4AWithMetadata :: OsPath -> OsPath -> Metadata -> AlbumArtUpdate -> Writer ()
copyM4AWithMetadata srcPath dstPath metadata artUpdate = do
  -- Parse source file to get atom structure
  atoms <- liftIO $ withBinaryFile srcPath ReadMode parseTopLevelAtoms

  -- Find moov atom
  case findMoovAtom atoms of
    Nothing -> throwError $ CorruptedWrite "No moov atom found"
    Just (moovOffset, moovSize) -> do
      -- Generate new ilst atom data
      ilstData <- generateIlstData metadata artUpdate

      -- Write to destination
      writeResult <- liftIO $ withBinaryFile srcPath ReadMode $ \srcHandle -> do
        withBinaryFile dstPath WriteMode $ \dstHandle -> do
          runExceptT $ rewriteM4AFile srcHandle dstHandle atoms moovOffset moovSize ilstData artUpdate

      either throwError return writeResult

-- Simple atom info for tracking during parse
data AtomInfo = AtomInfo
  { aiOffset :: Integer
  , aiSize :: Word64
  , aiName :: ByteString
  } deriving (Show)

-- | Parse top-level atoms (simplified, just track positions)
parseTopLevelAtoms :: Handle -> IO [AtomInfo]
parseTopLevelAtoms handle = do
  fileSize <- hFileSize handle
  hSeek handle AbsoluteSeek 0
  parseAtomsLoop handle fileSize []
  where
    parseAtomsLoop h endPos acc = do
      pos <- hTell h
      if pos + 8 > endPos
        then return $ reverse acc
        else do
          header <- BS.hGet h 8
          if BS.length header < 8
            then return $ reverse acc
            else do
              let size32 = readWord32BE $ BS.take 4 header
                  name = BS.take 4 $ BS.drop 4 header

              maybeSize <- if size32 == 1
                then do
                  sizeData <- BS.hGet h 8
                  return $ if BS.length sizeData < 8 || readWord64BE sizeData < 16
                    then Nothing  -- truncated or malformed extended size
                    else Just $ readWord64BE sizeData
                else if size32 == 0
                  then return $ Just $ fromIntegral (endPos - pos)  -- extends to EOF
                else if size32 < 8
                  then return Nothing  -- malformed: smaller than its own header
                else return $ Just $ fromIntegral size32

              case maybeSize of
                Nothing -> return $ reverse acc  -- stop on malformed atom
                Just actualSize -> do
                  let atomInfo = AtomInfo
                        { aiOffset = pos
                        , aiSize = actualSize
                        , aiName = name
                        }

                  hSeek h AbsoluteSeek (pos + fromIntegral actualSize)
                  parseAtomsLoop h endPos (atomInfo : acc)

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

-- | Rewrite M4A file with new metadata
rewriteM4AFile :: Handle -> Handle -> [AtomInfo] -> Integer -> Word64 -> L.ByteString -> AlbumArtUpdate -> Writer ()
rewriteM4AFile srcHandle dstHandle atoms moovOffset moovSize newIlstData artUpdate = do
  -- Copy all atoms before moov
  liftIO $ copyBeforeMoov srcHandle dstHandle atoms moovOffset

  -- Read and rewrite moov atom with new ilst
  liftIO $ do
    hSeek srcHandle AbsoluteSeek moovOffset
    moovData <- BS.hGet srcHandle (fromIntegral moovSize)

    -- When keeping existing art, carry the covr atom(s) from the old
    -- ilst over verbatim
    let keptCovr = case artUpdate of
          KeepExistingArt -> extractCovrAtoms (BS.drop 8 moovData)
          _ -> L.empty
        fullIlstData = newIlstData <> keptCovr

    -- Rebuild moov with new ilst, then fix up chunk offsets: stco/co64
    -- entries are absolute file positions, and resizing moov moves every
    -- byte after moov's old end by the size delta.
    let newMoovData = L.toStrict $ rebuildMoovAtom moovData fullIlstData
        delta = toInteger (BS.length newMoovData) - toInteger moovSize
        oldMoovEnd = moovOffset + fromIntegral moovSize
    BS.hPut dstHandle $ adjustChunkOffsets delta oldMoovEnd newMoovData

  -- Copy all atoms after moov
  liftIO $ copyAfterMoov srcHandle dstHandle moovOffset moovSize

-- | Extract the raw covr atom(s) from a moov atom's content by walking
-- udta > meta (skipping its version/flags) > ilst
extractCovrAtoms :: ByteString -> L.ByteString
extractCovrAtoms moovContent =
  case findChildAtom "udta" moovContent of
    Nothing -> L.empty
    Just udtaContent -> case findChildAtom "meta" udtaContent of
      Nothing -> L.empty
      Just metaContent -> case findChildAtom "ilst" (BS.drop 4 metaContent) of
        Nothing -> L.empty
        Just ilstContent -> L.fromStrict $ BS.concat (collectAtoms "covr" ilstContent)
  where
    -- Walk sibling atoms; return the named atom's content
    findChildAtom name bs = listToMaybe [c | (n, _, c) <- walkAtoms bs, n == name]

    -- Walk sibling atoms; return the named atoms verbatim (with header)
    collectAtoms name bs = [raw | (n, raw, _) <- walkAtoms bs, n == name]

    walkAtoms bs
      | BS.length bs < 8 = []
      | otherwise =
          let size32 = readWord32BE $ BS.take 4 bs
              name = BS.take 4 $ BS.drop 4 bs
              (headerLen, atomSize)
                | size32 == 0 = (8, BS.length bs)  -- atom extends to end
                | size32 == 1 && BS.length bs >= 16 =
                    (16, fromIntegral $ readWord64BE $ BS.take 8 $ BS.drop 8 bs)
                | otherwise = (8, fromIntegral size32)
          in if atomSize < headerLen || atomSize > BS.length bs
             then []  -- corrupt size; stop walking
             else
               let (atom, rest) = BS.splitAt atomSize bs
               in (name, atom, BS.drop headerLen atom) : walkAtoms rest

-- | Copy atoms before moov
copyBeforeMoov :: Handle -> Handle -> [AtomInfo] -> Integer -> IO ()
copyBeforeMoov srcHandle dstHandle atoms moovOffset = do
  hSeek srcHandle AbsoluteSeek 0
  let beforeAtoms = filter (\a -> aiOffset a < moovOffset) atoms
  mapM_ (copyAtom srcHandle dstHandle) beforeAtoms

-- | Copy atoms after moov
copyAfterMoov :: Handle -> Handle -> Integer -> Word64 -> IO ()
copyAfterMoov srcHandle dstHandle moovOffset moovSize = do
  let afterOffset = moovOffset + fromIntegral moovSize
  fileSize <- hFileSize srcHandle
  hSeek srcHandle AbsoluteSeek afterOffset

  let remaining = fileSize - afterOffset
  copyBytes srcHandle dstHandle (fromIntegral remaining)

-- | Copy a single atom
copyAtom :: Handle -> Handle -> AtomInfo -> IO ()
copyAtom srcHandle dstHandle atom = do
  hSeek srcHandle AbsoluteSeek (aiOffset atom)
  copyBytes srcHandle dstHandle (fromIntegral $ aiSize atom)

-- | Copy bytes from one handle to another
copyBytes :: Handle -> Handle -> Int -> IO ()
copyBytes srcHandle dstHandle count = go count
  where
    go n
      | n <= 0 = return ()
      | otherwise = do
          let chunkSize = min 65536 n
          chunk <- BS.hGet srcHandle chunkSize
          if BS.null chunk
            then return ()  -- premature EOF; nothing more to copy
            else do
              BS.hPut dstHandle chunk
              go (n - BS.length chunk)

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

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

      -- Build new moov with filtered children + new udta
      newMoovContent = childrenWithoutUdta <> newUdta
  in renderAtom "moov" newMoovContent
  where
    hdlrData = L.fromStrict $ BS.pack $ concat
      [ [0,0,0,0, 0,0,0,0]  -- version/flags + reserved
      , map (fromIntegral . fromEnum) "mdirappl"  -- handler_type + reserved
      , [0,0,0,0, 0,0,0,0, 0]  -- reserved
      ]

-- | Shift absolute chunk offsets in every stco/co64 table inside a moov atom.
-- Only offsets pointing at or beyond moov's old end move: data before moov
-- stays put, so those offsets stay valid regardless of the size delta.
adjustChunkOffsets :: Integer -> Integer -> ByteString -> ByteString
adjustChunkOffsets delta oldMoovEnd = goAtoms
  where
    containerNames = ["moov", "trak", "mdia", "minf", "stbl"] :: [ByteString]

    goAtoms bs
      | BS.length bs < 8 = bs
      | otherwise =
          let size32 = readWord32BE $ BS.take 4 bs
              name = BS.take 4 $ BS.drop 4 bs
              (headerLen, atomSize)
                | size32 == 0 = (8, BS.length bs)  -- atom extends to end
                | size32 == 1 && BS.length bs >= 16 =
                    (16, fromIntegral $ readWord64BE $ BS.take 8 $ BS.drop 8 bs)
                | otherwise = (8, fromIntegral size32)
          in if atomSize < headerLen || atomSize > BS.length bs
             then bs  -- corrupt size; leave the remainder untouched
             else
               let (atom, rest) = BS.splitAt atomSize bs
                   (header, content) = BS.splitAt headerLen atom
                   atom'
                     | name `elem` containerNames = header <> goAtoms content
                     | name == "stco" = header <> patchTable 4 content
                     | name == "co64" = header <> patchTable 8 content
                     | otherwise = atom
               in atom' <> goAtoms rest

    -- Table layout: version/flags (4) + entry count (4) + count offsets
    patchTable entryWidth content
      | BS.length content < 8 + tableLen = content
      | otherwise = prefix <> BS.concat (map patchEntry entries) <> trailer
      where
        count = if BS.length content >= 8
          then fromIntegral $ readWord32BE $ BS.take 4 $ BS.drop 4 content
          else 0
        tableLen = count * entryWidth
        (prefix, tableAndTrailer) = BS.splitAt 8 content
        (table, trailer) = BS.splitAt tableLen tableAndTrailer
        entries = [ BS.take entryWidth $ BS.drop (i * entryWidth) table
                  | i <- [0 .. count - 1] ]

    patchEntry entry =
      let wide = BS.length entry == 8
          old = if wide
                  then toInteger $ readWord64BE entry
                  else toInteger $ readWord32BE entry
          new = if old >= oldMoovEnd then old + delta else old
      in if new == old
         then entry
         else L.toStrict $ runPut $ if wide
                then putWord64be (fromIntegral new)
                else putWord32be (fromIntegral new)

-- | Filter out udta atom from a sequence of atoms
filterOutUdta :: ByteString -> L.ByteString
filterOutUdta bs = go bs L.empty
  where
    go remaining acc
      | BS.length remaining < 8 = acc
      | otherwise =
          let size32 = readWord32BE $ BS.take 4 remaining
              name = BS.take 4 $ BS.drop 4 remaining

              actualSize
                | size32 == 1 && BS.length remaining >= 16 =
                    fromIntegral $ readWord64BE $ BS.take 8 $ BS.drop 8 remaining
                | size32 == 0 = BS.length remaining  -- extends to end
                | otherwise = fromIntegral size32

              atomData = L.fromStrict $ BS.take actualSize remaining
              nextRemaining = BS.drop actualSize remaining

          in if actualSize < 8
             -- Malformed size would stall the loop; keep the rest verbatim
             then acc <> L.fromStrict remaining
             else if name == "udta"
             then go nextRemaining acc  -- Skip udta atom
             else go nextRemaining (acc <> atomData)  -- Keep other atoms

-- | Generate ilst atom data with all tags
-- | Generate ilst atom data with all tags. Every field the M4A parser maps
-- is written back, and unmapped atoms in rawTags are carried over so an
-- update never drops tags it does not understand.
generateIlstData :: Metadata -> AlbumArtUpdate -> Writer L.ByteString
generateIlstData metadata artUpdate = do
  let tags = concat
        [ renderTextTag "\169nam" <$> maybeToList (title metadata)
        , renderTextTag "\169ART" <$> maybeToList (artist metadata)
        , renderTextTag "\169alb" <$> maybeToList (album metadata)
        , renderTextTag "aART" <$> maybeToList (albumArtist metadata)
        , renderTextTag "\169day" <$> maybeToList (date metadata <|> (T.pack . show <$> year metadata))
        , renderTextTag "\169gen" <$> maybeToList (genre metadata)
        , renderTextTag "\169cmt" <$> maybeToList (comment metadata)
        , renderTextTag "\169pub" <$> maybeToList (publisher metadata)
        , maybeToList $ renderTrackDiskTag "trkn" (trackNumber metadata) (totalTracks metadata)
        , maybeToList $ renderTrackDiskTag "disk" (discNumber metadata) (totalDiscs metadata)
        -- Kept art is carried over verbatim by the moov rewrite instead
        , case artUpdate of
            SetAlbumArt art -> [renderCoverTag art]
            _ -> []
        -- Freeform tags for MusicBrainz-style metadata
        , renderFreeformTag "LABEL" <$> maybeToList (recordLabel metadata)
        , renderFreeformTag "CATALOGNUMBER" <$> maybeToList (catalogNumber metadata)
        , renderFreeformTag "BARCODE" <$> maybeToList (barcode metadata)
        , renderFreeformTag "MusicBrainz Album Release Country" <$> maybeToList (releaseCountry metadata)
        , renderFreeformTag "MusicBrainz Album Status" <$> maybeToList (releaseStatus metadata)
        , renderFreeformTag "MusicBrainz Album Type" <$> maybeToList (releaseType metadata)
        -- MusicBrainz IDs
        , renderMusicBrainzIds (musicBrainzIds metadata)
        -- Acoustid
        , renderFreeformTag "Acoustid Fingerprint" <$> maybeToList (acoustidFingerprint metadata)
        , renderFreeformTag "Acoustid Id" <$> maybeToList (acoustidId metadata)
        -- Unmapped tags carried over from the source file
        , concat
            [ renderPreservedTag key value
            | (key, values) <- HM.toList (rawTags metadata)
            , value <- values
            ]
        ]

  return $ mconcat tags
  where
    renderMusicBrainzIds mbids = concat
      [ renderFreeformTag "MusicBrainz Release Track Id" <$> maybeToList (mbTrackId mbids)
      , renderFreeformTag "MusicBrainz Track Id" <$> maybeToList (mbRecordingId mbids)
      , renderFreeformTag "MusicBrainz Album Id" <$> maybeToList (mbReleaseId mbids)
      , renderFreeformTag "MusicBrainz Release Group Id" <$> maybeToList (mbReleaseGroupId mbids)
      , renderFreeformTag "MusicBrainz Artist Id" <$> maybeToList (mbArtistId mbids)
      , renderFreeformTag "MusicBrainz Album Artist Id" <$> maybeToList (mbAlbumArtistId mbids)
      , renderFreeformTag "MusicBrainz Work Id" <$> maybeToList (mbWorkId mbids)
      , renderFreeformTag "MusicBrainz Disc Id" <$> maybeToList (mbDiscId mbids)
      ]

    -- Atoms the mapped fields own (whether or not they are set right now):
    -- stale rawTags copies of these must not be written back
    handledAtoms =
      [ "\169nam", "\169ART", "\169alb", "aART", "\169day", "\169gen"
      , "\169cmt", "\169pub"
      ] :: [Text]

    handledFreeform = map ("----:com.apple.iTunes:" <>)
      [ "LABEL", "CATALOGNUMBER", "BARCODE"
      , "MusicBrainz Album Release Country", "MusicBrainz Album Status"
      , "MusicBrainz Album Type"
      , "MusicBrainz Release Track Id", "MusicBrainz Track Id"
      , "MusicBrainz Album Id", "MusicBrainz Release Group Id"
      , "MusicBrainz Artist Id", "MusicBrainz Album Artist Id"
      , "MusicBrainz Work Id", "MusicBrainz Disc Id"
      , "Acoustid Fingerprint", "Acoustid Id"
      ] :: [Text]

    -- rawTags only holds text-decoded values, so preservation is limited to
    -- tags that can be reproduced faithfully from text: \169-prefixed text
    -- atoms and freeform (----) tags. Typed atoms (trkn, disk, covr, tmpo,
    -- ...) are either regenerated from mapped fields or skipped
    renderPreservedTag :: Text -> Text -> [L.ByteString]
    renderPreservedTag key value
      | key `elem` handledAtoms || key `elem` handledFreeform = []
      | Just rest <- T.stripPrefix "----:" key
      , (mean, nameWithColon) <- T.breakOn ":" rest
      , name <- T.drop 1 nameWithColon
      , not (T.null mean) && not (T.null name)
      = [renderFreeformTagWith (TE.encodeUtf8 mean) (TE.encodeUtf8 name) value]
      | T.isPrefixOf "\169" key
      , T.length key == 4
      , all ((< 256) . fromEnum) (T.unpack key)
      = [renderTextTag (latin1Bytes key) value]
      | otherwise = []

    latin1Bytes = BS.pack . map (fromIntegral . fromEnum) . T.unpack

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

-- | Render track/disk number tag. iTunes convention: trkn carries a
-- trailing reserved word (8 bytes), disk does not (6 bytes). Values are
-- clamped to the 16-bit field rather than silently wrapping.
renderTrackDiskTag :: ByteString -> Maybe Int -> Maybe Int -> Maybe L.ByteString
renderTrackDiskTag name (Just current) maybeTotal =
  let total = fromMaybe 0 maybeTotal
      clamp16 n = fromIntegral (max 0 (min 0xFFFF n))
      trackData = runPut $ do
        putWord16be 0  -- reserved
        putWord16be (clamp16 current)
        putWord16be (clamp16 total)
      trailing = if name == "trkn" then runPut (putWord16be 0) else L.empty
      dataAtom = renderDataAtom 0 (L.toStrict (trackData <> trailing))  -- Type 0 = implicit
  in Just $ renderAtom name dataAtom
renderTrackDiskTag _ Nothing _ = Nothing

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

-- | Render freeform tag (----:com.apple.iTunes:NAME)
renderFreeformTag :: ByteString -> Text -> L.ByteString
renderFreeformTag = renderFreeformTagWith "com.apple.iTunes"

-- | Render freeform tag (----:MEAN:NAME) with an explicit mean
renderFreeformTagWith :: ByteString -> ByteString -> Text -> L.ByteString
renderFreeformTagWith mean name value =
  let meanAtom = renderAtom "mean" (runPut (putWord32be 0) <> L.fromStrict mean)
      nameAtom = renderAtom "name" (runPut (putWord32be 0) <> L.fromStrict name)
      textData = TE.encodeUtf8 value
      dataAtom = renderDataAtom 1 textData  -- Type 1 = UTF-8
  in renderAtom "----" (meanAtom <> nameAtom <> 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 dataType content =
  let header = runPut $ do
        putWord32be dataType  -- version/flags with type
        putWord32be 0         -- Appears to be a reserved/locale field
  in renderAtom "data" (header <> L.fromStrict content)

-- | Render an atom with name and data
renderAtom :: ByteString -> L.ByteString -> L.ByteString
renderAtom name content =
  let size = 8 + L.length content
      header = runPut $ do
        putWord32be (fromIntegral size)
        putByteString name
  in header <> content

-- Helper functions
readWord32BE :: ByteString -> Word32
readWord32BE bs =
  let b0 = fromIntegral (BS.index bs 0) :: Word32
      b1 = fromIntegral (BS.index bs 1) :: Word32
      b2 = fromIntegral (BS.index bs 2) :: Word32
      b3 = fromIntegral (BS.index bs 3) :: Word32
  in (b0 `shiftL` 24) .|. (b1 `shiftL` 16) .|. (b2 `shiftL` 8) .|. b3

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