GLB.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}

module Codec.GLB
  ( GLB(..)
  , Header(..)
  , Chunk(..)
  , fromByteString
  , fromFile
  ) where

import Prelude hiding (length)

import Data.Binary (Binary(..), decodeFileOrFail, decodeOrFail)
import Data.Binary.Get (ByteOffset, getWord32le, getByteString, isEmpty)
import Data.Binary.Put (putByteString, putWord32le)
import Data.ByteString (ByteString)
import Data.Vector (Vector, unfoldrM)
import Data.Word (Word32)
import GHC.Generics (Generic)

import qualified Data.ByteString.Lazy as BSL

fromByteString :: ByteString -> Either (ByteOffset, String) GLB
fromByteString bs =
  case decodeOrFail (BSL.fromStrict bs) of
    Right (_leftovers, _bytesLeft, ktx) ->
      Right ktx
    Left (_leftovers, bytesLeft, err) ->
      Left (bytesLeft, err)

fromFile :: FilePath -> IO (Either (ByteOffset, String) GLB)
fromFile = decodeFileOrFail

data GLB = GLB
  { header :: Header
  , chunks :: Vector Chunk
  } deriving (Eq, Show, Generic)

instance Binary GLB where
  get = GLB <$> get <*> unfoldrM getChunks ()
    where
      getChunks () = do
        done <- isEmpty
        if done then
          pure Nothing
        else do
          chunk <- get
          pure $ Just (chunk, ())

  put GLB{..} = do
    put header
    mapM_ put chunks

data Header = Header
  { magic   :: Word32
  , version :: Word32
  , length  :: Word32
  } deriving (Eq, Show, Generic)

instance Binary Header where
  get = Header
    <$> getWord32le
    <*> getWord32le
    <*> getWord32le

  put Header{..} = do
    putWord32le magic
    putWord32le version
    putWord32le length

data Chunk = Chunk
  { chunkLength :: Word32
  , chunkType   :: Word32
  , chunkData   :: ByteString
  }
  deriving (Eq, Show, Generic)

instance Binary Chunk where
  get = do
    chunkLength <- getWord32le
    chunkType   <- getWord32le
    chunkData   <- getByteString (fromIntegral chunkLength)
    pure Chunk{..}

  put Chunk{..} = do
    putWord32le   chunkLength
    putWord32le   chunkType
    putByteString chunkData