diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,16 @@ # Changelog for ktx-codec +## [0.0.2.0] - 2023-03-18 + +* Add experimental KTX 2.0 support. + * Only reading for now. + * Everything besides the header is read on demand. + * MipLevel data can be read into provided buffer directly. +* `KeyValueData` moved to `Codec.Ktx.KeyValue` and dropped the `Key` newtype. + * Add `textual` to extract all valid text values. + +[0.0.2.0]: https://gitlab.com/dpwiz/ktx/-/tree/v0.0.2.0-codec + ## [0.0.1.4] - 2022-01-24 * Put tests under a flag. No code change. diff --git a/ktx-codec.cabal b/ktx-codec.cabal --- a/ktx-codec.cabal +++ b/ktx-codec.cabal @@ -1,21 +1,24 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack name: ktx-codec -version: 0.0.1.4 +version: 0.0.2.0 synopsis: Khronos texture format -description: KTX is a format for storing textures for OpenGL® and OpenGL® ES applications. - It is distinguished by the simplicity of the loader required to instantiate a - GL texture object from the file contents. +description: This package implements low-level encoding and decoding for .ktx and .ktx2 files. . - https://web.archive.org/web/20201116105642/https://www.khronos.org/opengles/sdk/tools/KTX/file_format_spec/ + A framework-specific wrapper may be needed to work with the decoded data and/or supercompression. + Check out test/Spec.hs for usage examples. + . + KTX 1: https://registry.khronos.org/KTX/specs/1.0/ktxspec.v1.html + . + KTX 2: https://registry.khronos.org/KTX/specs/2.0/ktxspec.v2.html#_abstract category: Graphics -author: Alexander Bondarenko +author: IC Rainbow maintainer: aenor.realm@gmail.com -copyright: 2021 Alexander Bondarenko +copyright: 2023 IC Rainbow license: BSD3 license-file: LICENSE build-type: Simple @@ -33,6 +36,12 @@ library exposed-modules: Codec.Ktx + Codec.Ktx.KeyValue + Codec.Ktx2.DFD + Codec.Ktx2.DFD.Khronos.BasicV2 + Codec.Ktx2.Header + Codec.Ktx2.Level + Codec.Ktx2.Read other-modules: Paths_ktx_codec hs-source-dirs: @@ -41,14 +50,17 @@ ApplicativeDo BlockArguments DeriveGeneric - DuplicateRecordFields FlexibleContexts GeneralizedNewtypeDeriving + ImportQualifiedPost LambdaCase + NamedFieldPuns OverloadedStrings PatternSynonyms RecordWildCards StrictData + TypeApplications + ghc-options: -Wall build-depends: base >=4.7 && <5 , binary >=0.8.7 && <1 @@ -69,15 +81,17 @@ ApplicativeDo BlockArguments DeriveGeneric - DuplicateRecordFields FlexibleContexts GeneralizedNewtypeDeriving + ImportQualifiedPost LambdaCase + NamedFieldPuns OverloadedStrings PatternSynonyms RecordWildCards StrictData - ghc-options: -threaded -rtsopts -with-rtsopts=-N + TypeApplications + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 , binary >=0.8.7 && <1 @@ -87,8 +101,11 @@ , filepath ==1.4.* , ktx-codec , shower ==0.2.* + , tasty + , tasty-hunit , text >=1.2 && <2.1 , vector ==0.12.* + , zstd + default-language: Haskell2010 if !flag(tests) buildable: False - default-language: Haskell2010 diff --git a/src/Codec/Ktx.hs b/src/Codec/Ktx.hs --- a/src/Codec/Ktx.hs +++ b/src/Codec/Ktx.hs @@ -1,24 +1,21 @@ module Codec.Ktx where import Data.Binary (Binary(..), decodeFileOrFail, decodeOrFail) -import Data.Binary.Get (Get, ByteOffset, getWord32le, getWord32be, getByteString, isolate, skip) +import Data.Binary.Get (Get, ByteOffset, getWord32le, getWord32be, getByteString) import Data.Binary.Put (Put, execPut, putByteString, putWord32le, putWord32be) import Data.ByteString (ByteString) +import Data.ByteString qualified as BS import Data.ByteString.Builder (Builder, hPutBuilder) +import Data.ByteString.Lazy qualified as BSL import Data.Coerce (coerce) -import Data.Foldable (for_) -import Data.Map.Strict (Map) -import Data.Text (Text) import Data.Vector (Vector) +import Data.Vector qualified as Vector import Data.Word (Word32) import GHC.Generics (Generic) import System.IO (IOMode(..), withBinaryFile) -import qualified Data.Text.Encoding as Text -import qualified Data.Map.Strict as Map -import qualified Data.Vector as Vector -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL +import Codec.Ktx.KeyValue (KeyValueData) +import Codec.Ktx.KeyValue qualified as KeyValue fromByteStringLazy :: BSL.ByteString -> Either (ByteOffset, String) Ktx fromByteStringLazy bsl = @@ -51,13 +48,15 @@ instance Binary Ktx where get = do header <- get - kvs <- getKeyValueData header + kvs <- KeyValue.getData + (mkGetWord32 $ endianness header) + (fromIntegral $ bytesOfKeyValueData header) images <- getImages header pure Ktx{..} put Ktx{..} = do put header - putKeyValueData putWord32 kvs + KeyValue.putData putWord32 kvs putImages putWord32 images where putWord32 = mkPutWord32 $ endianness header @@ -139,69 +138,6 @@ , 0x0D, 0x0A, 0x1A, 0x0A -- \r\n\x1A\n ] --- * Key-value data - -type KeyValueData = Map Key Value - -newtype Key = Key Text - deriving (Eq, Ord, Show, Generic) - -newtype Value = Value ByteString - deriving (Show, Generic) - -getKeyValueData :: Header -> Get KeyValueData -getKeyValueData Header{..} = - isolate (fromIntegral bytesOfKeyValueData) $ - go (toInteger bytesOfKeyValueData) [] - where - go remains acc - | remains == 0 = - pure $ Map.fromList acc - - | remains < 0 = - fail "Attempted to read beyond bytesOfKeyValueData" - - | otherwise = do - keyAndValueByteSize <- fmap toInteger getSize - let paddingSize = 3 - ((keyAndValueByteSize + 3) `rem` 4) - - keyAndValue <- getByteString (fromInteger keyAndValueByteSize) - skip (fromInteger paddingSize) - - {- XXX: Spec says: - Any byte value is allowed. - It is encouraged that the value be a NUL terminated UTF-8 string but this is not required. - If the Value data is a string of bytes then the NUL termination - should be included in the keyAndValueByteSize byte count - (but programs that read KTX files must not rely on this). - -} - let - (keyBS, valueBS) = BS.span (/= 0x00) keyAndValue - key = Key $ Text.decodeUtf8 keyBS - value = Value $ BS.drop 1 valueBS - - go - (remains - 4 - keyAndValueByteSize - paddingSize) - ((key, value) : acc) - - getSize = - if endianness == endiannessLE then - getWord32le - else - getWord32be - -putKeyValueData :: (Word32 -> Put) -> Map Key Value -> Put -putKeyValueData endianPut kvs = - for_ (Map.toList kvs) \(Key key, Value value) -> do - let - keyAndValue = Text.encodeUtf8 key <> BS.singleton 0x00 <> value - keyAndValueByteSize = BS.length keyAndValue - paddingSize = 3 - ((keyAndValueByteSize + 3) `rem` 4) - - endianPut (fromIntegral keyAndValueByteSize) - putByteString keyAndValue - putByteString $ BS.replicate paddingSize 0 - -- * Images type MipLevels = Vector MipLevel @@ -294,6 +230,13 @@ putByteString block -- * Utils + +mkGetWord32 :: Word32 -> Get Word32 +mkGetWord32 someEndianness = + if someEndianness == endiannessLE then + getWord32le + else + getWord32be mkPutWord32 :: Word32 -> (Word32 -> Put) mkPutWord32 someEndianness = diff --git a/src/Codec/Ktx/KeyValue.hs b/src/Codec/Ktx/KeyValue.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Ktx/KeyValue.hs @@ -0,0 +1,126 @@ +module Codec.Ktx.KeyValue + ( KeyValueData + + -- * Writing + , Value(..) + , text + , bytes + , number + + -- * Reading + , FromValue(..) + , textual + + -- * Binary operations + , getDataLe + , getData + + , putDataLe + , putData + ) where + +import Data.Binary.Get (Get, getWord32le, getByteString, isolate, skip) +import Data.Binary.Put (Put, putByteString, putWord32le) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Foldable (for_) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as Text (pack) +import Data.Text.Encoding qualified as Text +import Data.Word (Word32) +import GHC.Generics (Generic) + +type KeyValueData = Map Text Value + +{- | A wrapper for raw data. + +Use "FromValue"/"ToValue" to process. +-} +newtype Value = Value ByteString + deriving (Eq, Show, Generic) + +class FromValue a where + fromValue :: Value -> Maybe a + +instance FromValue Text where + fromValue (Value bs) + | BS.null bs = + Nothing + | BS.last bs == 0x00 = + either (const Nothing) Just $ + Text.decodeUtf8' $ BS.init bs + | otherwise = + Nothing + +instance FromValue ByteString where + fromValue (Value bs) = Just bs + +text :: Text -> Value +text t = Value $ BS.snoc (Text.encodeUtf8 t) 0x00 + +bytes :: ByteString -> Value +bytes = Value + +number :: (Num a, Show a) => a -> Value +number = text . Text.pack . show + +-- | Extract all valid (null-terminated utf8) values. +textual :: KeyValueData -> Map Text Text +textual = Map.mapMaybe fromValue + +{-# INLINE getDataLe #-} +getDataLe :: Int -> Get KeyValueData +getDataLe = getData getWord32le + +getData :: Get Word32 -> Int -> Get KeyValueData +getData getSize bytesOfKeyValueData = + isolate bytesOfKeyValueData $ + go bytesOfKeyValueData [] + where + go remains acc + | remains == 0 = + pure $ Map.fromList acc + + | remains < 0 = + fail "Attempted to read beyond bytesOfKeyValueData" + + | otherwise = do + keyAndValueByteSize <- fmap fromIntegral getSize + let paddingSize = 3 - ((keyAndValueByteSize + 3) `rem` 4) + + keyAndValue <- getByteString keyAndValueByteSize + skip paddingSize + + {- XXX: Spec says: + Any byte value is allowed. + It is encouraged that the value be a NUL terminated UTF-8 string but this is not required. + If the Value data is a string of bytes then the NUL termination + should be included in the keyAndValueByteSize byte count + (but programs that read KTX files must not rely on this). + -} + let + (keyBS, valueBS) = BS.span (/= 0x00) keyAndValue + key = Text.decodeUtf8 keyBS + value = Value $ BS.drop 1 valueBS + + go + (remains - keyAndValueByteSize - 4 - paddingSize) + ((key, value) : acc) + +{-# INLINE putDataLe #-} +putDataLe :: KeyValueData -> Put +putDataLe = putData putWord32le + +putData :: (Word32 -> Put) -> KeyValueData -> Put +putData putSize kvs = + for_ (Map.toList kvs) \(key, Value value) -> do + let + keyAndValue = mconcat [Text.encodeUtf8 key, BS.singleton 0x00, value] + keyAndValueByteSize = BS.length keyAndValue + paddingSize = 3 - ((keyAndValueByteSize + 3) `rem` 4) + + putSize (fromIntegral keyAndValueByteSize) + putByteString keyAndValue + putByteString $ BS.replicate paddingSize 0 diff --git a/src/Codec/Ktx2/DFD.hs b/src/Codec/Ktx2/DFD.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Ktx2/DFD.hs @@ -0,0 +1,65 @@ +module Codec.Ktx2.DFD where + +import Data.Binary (Binary(..)) +import Data.Binary.Get (getWord32le, getByteString, isolate) +import Data.Binary.Put (putByteString, putWord32le) +import Data.Bits (shiftR, Bits ((.&.), shiftL, (.|.))) +import Data.ByteString (ByteString) +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Data.Word (Word32) +import GHC.Generics (Generic) + +data DFD = DFD + { dfdTotalSize :: Word32 + , dfdBlocks :: Vector Block + } + deriving (Eq, Show, Generic) + +instance Binary DFD where + get = do + dfdTotalSize <- getWord32le + dfdBlocks <- isolate (fromIntegral dfdTotalSize - 4) do + flip Vector.unfoldrM (dfdTotalSize - 4) \case + 0 -> + pure Nothing + remaining | remaining < 0 -> + error "reading beyond end of block" + remaining -> do + block <- get + pure $ Just + ( block + , remaining - descriptorBlockSize block + ) + pure DFD{..} + + put DFD{..} = do + putWord32le dfdTotalSize + Vector.mapM_ put dfdBlocks + +data Block = Block + { descriptorType :: Word32 + , vendorId :: Word32 + , descriptorBlockSize :: Word32 + , versionNumber :: Word32 + , body :: ByteString + } + deriving (Eq, Show, Generic) + +instance Binary Block where + get = do + a <- getWord32le + let + descriptorType = shiftR a 17 + vendorId = a .&. 0x0001FFFF + b <- getWord32le + let + descriptorBlockSize = shiftR b 16 + versionNumber = b .&. 0x0000FFFF + body <- getByteString $ fromIntegral (descriptorBlockSize - 8) + pure Block{..} + + put Block{..} = do + put $ shiftL descriptorType 17 .|. vendorId + put $ shiftL descriptorBlockSize 16 .|. versionNumber + putByteString body diff --git a/src/Codec/Ktx2/DFD/Khronos/BasicV2.hs b/src/Codec/Ktx2/DFD/Khronos/BasicV2.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Ktx2/DFD/Khronos/BasicV2.hs @@ -0,0 +1,190 @@ +module Codec.Ktx2.DFD.Khronos.BasicV2 where + +import Data.Binary (Binary(..)) +import Data.Binary.Get (Get, getWord8, getWord16le, getWord32le, runGetOrFail) +import Data.Binary.Put (PutM, putWord8, putWord16le, putWord32le, runPut) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL +import Data.ByteString.Lazy qualified as LBS +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Data.Word (Word8, Word16, Word32) +import GHC.Generics (Generic) + +import Codec.Ktx2.DFD qualified as DFD + +-- | Khronos +pattern VENDOR_ID :: (Eq a, Num a) => a +pattern VENDOR_ID = 0 + +-- | Basic DFD Block +pattern DESCRIPTOR_TYPE :: (Eq a, Num a) => a +pattern DESCRIPTOR_TYPE = 0 + +-- | KDF v1.3 +pattern VERSION :: (Eq a, Num a) => a +pattern VERSION = 2 + +{- | + A basic descriptor block is designed to encode common metadata associated with bulk data — especially image or texture data. + + While this descriptor holds more information about the data interpretation than is needed by many applications, + a comprehensive encoding reduces the risk of metadata needed by different APIs being lost in translation. + + The format is described in terms of a repeating axis-aligned texel block composed of samples. + Each sample contains a single channel of information with a single spatial offset within the texel block, + and consists of an amount of contiguous data. This descriptor block consists of information about the interpretation + of the texel block as a whole, supplemented by a description of a number of samples taken from one or more planes of contiguous memory. + + +-} +data BasicV2 = BasicV2 + { colorModel :: Word8 + , colorPrimaries :: Word8 + , transferFunction :: Word8 + , flags :: Word8 + + , texelBlockDimension0 :: Word8 + {- ^ + The value held in each of these fields is one fewer than the size of the block in that dimension —  + that is, a value of 0 represents a size of 1, a value of 1 represents a size of 2, etc. + + A texel block which covers fewer than four dimensions should have a size of 1 in each dimension + that it lacks, and therefore the corresponding fields in the representation should be 0. + -} + , texelBlockDimension1 :: Word8 + , texelBlockDimension2 :: Word8 + , texelBlockDimension3 :: Word8 + + , bytesPlane0 :: Word8 + , bytesPlane1 :: Word8 + , bytesPlane2 :: Word8 + , bytesPlane3 :: Word8 + , bytesPlane4 :: Word8 + , bytesPlane5 :: Word8 + , bytesPlane6 :: Word8 + , bytesPlane7 :: Word8 + + , samples :: Vector Sample + } + deriving (Eq, Show, Generic) + +getter :: Int -> Get BasicV2 +getter numSamples = do + colorModel <- getWord8 + colorPrimaries <- getWord8 + transferFunction <- getWord8 + flags <- getWord8 + + texelBlockDimension0 <- fmap (+ 1) getWord8 + texelBlockDimension1 <- fmap (+ 1) getWord8 + texelBlockDimension2 <- fmap (+ 1) getWord8 + texelBlockDimension3 <- fmap (+ 1) getWord8 + + bytesPlane0 <- getWord8 + bytesPlane1 <- getWord8 + bytesPlane2 <- getWord8 + bytesPlane3 <- getWord8 + bytesPlane4 <- getWord8 + bytesPlane5 <- getWord8 + bytesPlane6 <- getWord8 + bytesPlane7 <- getWord8 + + samples <- Vector.replicateM numSamples get + + pure BasicV2{..} + +putter :: BasicV2 -> PutM () +putter BasicV2{..} = do + putWord8 colorModel + putWord8 colorPrimaries + putWord8 transferFunction + putWord8 flags + + putWord8 $ texelBlockDimension0 - 1 + putWord8 $ texelBlockDimension1 - 1 + putWord8 $ texelBlockDimension2 - 1 + putWord8 $ texelBlockDimension3 - 1 + + putWord8 bytesPlane0 + putWord8 bytesPlane1 + putWord8 bytesPlane2 + putWord8 bytesPlane3 + putWord8 bytesPlane4 + putWord8 bytesPlane5 + putWord8 bytesPlane6 + putWord8 bytesPlane7 + + Vector.mapM_ put samples + +data Sample = Sample + { bitOffset :: Word16 + , bitLength :: Word8 + , channelType :: Word8 + + , samplePosition0 :: Word8 + , samplePosition1 :: Word8 + , samplePosition2 :: Word8 + , samplePosition3 :: Word8 + + , sampleLower :: Word32 + , sampleUpper :: Word32 + } + deriving (Eq, Show, Generic) + +instance Binary Sample where + get = do + bitOffset <- getWord16le + bitLength <- fmap (+1) getWord8 + channelType <- getWord8 + + samplePosition0 <- getWord8 + samplePosition1 <- getWord8 + samplePosition2 <- getWord8 + samplePosition3 <- getWord8 + + sampleLower <- getWord32le + sampleUpper <- getWord32le + + pure Sample{..} + + put Sample{..} = do + putWord16le bitOffset + putWord8 $ bitLength - 1 + putWord8 channelType + + putWord8 samplePosition0 + putWord8 samplePosition1 + putWord8 samplePosition2 + putWord8 samplePosition3 + + putWord32le sampleLower + putWord32le sampleUpper + +fromBlock :: DFD.Block -> Maybe BasicV2 +fromBlock DFD.Block{descriptorBlockSize, body} = + case runGetOrFail (getter numSamples) (LBS.fromChunks [body]) of + Left _err -> + Nothing + Right (_bytes, _offset, ok) -> + Just ok + where + numSamples = + div (fromIntegral descriptorBlockSize - 24) 16 + +toBlock :: BasicV2 -> DFD.Block +toBlock v2 = + DFD.Block + { descriptorType = + DESCRIPTOR_TYPE + , vendorId = + VENDOR_ID + , versionNumber = + VERSION + , descriptorBlockSize = + fromIntegral $ BS.length body + 8 + , body = + body + } + where + body = BSL.toStrict . runPut $ putter v2 diff --git a/src/Codec/Ktx2/Header.hs b/src/Codec/Ktx2/Header.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Ktx2/Header.hs @@ -0,0 +1,97 @@ +module Codec.Ktx2.Header where + +import Data.Binary (Binary(..)) +import Data.Binary.Get (getWord32le, getWord64le, getByteString) +import Data.Binary.Put (putByteString, putWord32le, putWord64le) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Word (Word32, Word64) +import GHC.Generics (Generic) + +data Header = Header + { vkFormat :: Word32 -- ^ Specifies the image format using Vulkan @VkFormat@ enum values. It can be any value defined in core Vulkan 1.2, future core versions or registered Vulkan extensions, except for values listed in Table 1, “Prohibited Formats” and any @*SCALED*@ or @*[2-9]PLANE*@ formats added in future. + , typeSize :: Word32 -- ^ Specifies the size of the data type in bytes used to upload the data to a graphics API. When @typeSize@ is greater than 1, software on big-endian systems must endian convert all image data since it is little-endian. When format is @VK_FORMAT_UNDEFINED@, typeSize must equal 1. + + , pixelWidth :: Word32 + , pixelHeight :: Word32 + , pixelDepth :: Word32 + + , layerCount :: Word32 -- ^ Specifies the number of array elements. If the texture is not an array texture, @layerCount@ must equal 0. + , faceCount :: Word32 -- ^ If @faceCount@ is equal to 6, @pixelHeight@ must be equal to @pixelWidth@, and @pixelDepth@ must be 0. + , levelCount :: Word32 -- ^ Specifies the number of levels in the Mip Level Array and, by extension, the number of indices in the Level Index array. A KTX file does not need to contain a complete mipmap pyramid. + + , supercompressionScheme :: Word32 -- ^ Indicates if a supercompression scheme has been applied to the data in levelImages. It must be one of the values from Table 2, “Supercompression Schemes”. A value of 0 indicates no supercompression. + + -- Static index + , dfdByteOffset :: Word32 -- ^ The offset from the start of the file of the @dfdTotalSize@ field of the Data Format Descriptor. + , dfdByteLength :: Word32 -- ^ The total number of bytes in the Data Format Descriptor including the @dfdTotalSize@ field. @dfdByteLength@ must equal @dfdTotalSize@. + , kvdByteOffset :: Word32 -- ^ An arbitrary number of key/value pairs may follow the Index. These can be used to encode any arbitrary data. The kvdByteOffset field gives the offset of this data, i.e. that of first key/value pair, from the start of the file. The value must be 0 when kvdByteLength = 0. + , kvdByteLength :: Word32 -- ^ The total number of bytes of key/value data including all keyAndValueByteLength fields, all keyAndValue fields and all valuePadding fields. + , sgdByteOffset :: Word64 -- ^ The offset from the start of the file of supercompressionGlobalData. The value must be 0 when sgdByteLength = 0. + , sgdByteLength :: Word64 -- ^ The number of bytes of supercompressionGlobalData. For supercompression schemes for which no reference is provided in the Global Data Format column of Table 2, “Supercompression Schemes”. the value must be 0. + } deriving (Eq, Show, Generic) + +instance Binary Header where + get = do + identifier <- getByteString 12 + if identifier == canonicalIdentifier then + pure () + else + fail $ "KTX2 identifier mismatch: " <> show identifier + + vkFormat <- getWord32le + typeSize <- getWord32le + pixelWidth <- getWord32le + pixelHeight <- getWord32le + pixelDepth <- getWord32le + layerCount <- getWord32le + faceCount <- getWord32le + levelCount <- getWord32le + supercompressionScheme <- getWord32le + + dfdByteOffset <- getWord32le + dfdByteLength <- getWord32le + kvdByteOffset <- getWord32le + kvdByteLength <- getWord32le + sgdByteOffset <- getWord64le + sgdByteLength <- getWord64le + + pure Header{..} + + put Header{..} = do + putByteString canonicalIdentifier + + putWord32le vkFormat + putWord32le typeSize + putWord32le pixelWidth + putWord32le pixelHeight + putWord32le pixelDepth + putWord32le layerCount + putWord32le faceCount + putWord32le levelCount + putWord32le supercompressionScheme + + putWord32le dfdByteOffset + putWord32le dfdByteLength + putWord32le kvdByteOffset + putWord32le kvdByteLength + putWord64le sgdByteOffset + putWord64le sgdByteLength + +canonicalIdentifier :: ByteString +canonicalIdentifier = BS.pack + [ 0xAB, 0x4B, 0x54, 0x58, 0x20, 0x32, 0x30 -- «KTX 20» + , 0xBB, 0x0D, 0x0A, 0x1A, 0x0A -- \r\n\x1A\n + ] + +pattern SC_NONE :: (Eq a, Num a) => a +pattern SC_NONE = 0 + +pattern SC_BASISLZ :: (Eq a, Num a) => a +pattern SC_BASISLZ = 1 + +pattern SC_ZSTANDARD :: (Eq a, Num a) => a +pattern SC_ZSTANDARD = 2 + +pattern SC_ZLIB :: (Eq a, Num a) => a +pattern SC_ZLIB = 3 diff --git a/src/Codec/Ktx2/Level.hs b/src/Codec/Ktx2/Level.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Ktx2/Level.hs @@ -0,0 +1,25 @@ +module Codec.Ktx2.Level where + +import Data.Binary (Binary(..)) +import Data.Binary.Get (getWord64le) +import Data.Binary.Put (putWord64le) +import Data.Word (Word64) +import GHC.Generics (Generic) + +data Level = Level + { byteOffset :: Word64 -- ^ The offset from the start of the file of the first byte of image data for mip level. It is the offset of the first byte after any @mipPadding@. + , byteLength :: Word64 -- ^ The total size of the data for supercompressed mip level. + , uncompressedByteLength :: Word64 -- ^ the number of bytes of pixel data in LOD level after reflation from supercompression. This includes all z slices, all faces, all rows (or rows of blocks) and all pixels (or blocks) in each row for the mipmap level. When @supercompressionScheme == 0@, @byteLength@ must have the same value as this. When @supercompressionScheme == 1@ (BasisLZ) the value must be 0. + } deriving (Eq, Show, Generic) + +instance Binary Level where + get = do + byteOffset <- getWord64le + byteLength <- getWord64le + uncompressedByteLength <- getWord64le + pure Level{..} + + put Level{..} = do + putWord64le byteOffset + putWord64le byteLength + putWord64le uncompressedByteLength diff --git a/src/Codec/Ktx2/Read.hs b/src/Codec/Ktx2/Read.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Ktx2/Read.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE FlexibleInstances #-} + +{- | Block-by-block extraction of data from a KTX2 file. + +* Acquire a "Context". Header data is available without reading the rest of the source. +* Read 'levels' index. An memory allocation information is available. +* Consult 'Codec.Ktx2.Header.supercompressionScheme' and copy level data to decompression staging buffer or GPU memory directly. + +Extra information is available when needed: + +* Image metadata. +* Data Format Descriptor. Khronos Basic descriptor block is usually present, but a file may contain more. +* Supercompression data shared between all the levels. +-} + +module Codec.Ktx2.Read + ( Context(..) + + , FileContext + , open + , close + + , BytesContext + , bytes + + -- * Reading blocks + + -- ** Image data + , levels + , levelToPtr + , levelData + + -- ** Supplemental information + , dataFormatDescriptor + , keyValueData + , supercompressionGlobalData + + -- * Decoding internals + , ReadChunk(..) + , ChunkError(..) + , decodeAt + , DecodeError(..) + , ReadLevel(..) + ) where + +import Control.Exception (Exception, throwIO) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Binary (Binary(..)) +import Data.Binary.Get (Get, ByteOffset, getByteString, runGetOrFail) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL +import Data.ByteString.Unsafe qualified as BSU +import Data.String (fromString) +import Data.Text (Text) +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Foreign (Ptr, plusPtr) +import Foreign qualified +import System.IO qualified as IO + +import Codec.Ktx.KeyValue (KeyValueData) +import Codec.Ktx.KeyValue qualified as KeyValue +import Codec.Ktx2.Header (Header(..)) +import Codec.Ktx2.Level (Level(..)) +import Codec.Ktx2.DFD (DFD) + +-- * Context + +-- | A bundle of source data and header information used by reader functions. +data Context a = Context + { context :: a + , header :: Header + } + +-- ** Reading from files + +-- | Context for reading from a file. The file has to be seekable. +type FileContext = Context IO.Handle + +instance ReadChunk IO.Handle where + readChunkAt handle offset size = liftIO do + IO.hSeek handle IO.AbsoluteSeek (fromIntegral offset) + BS.hGet handle size + +instance ReadLevel IO.Handle where + readLevelTo handle Level{..} ptr = liftIO do + IO.hSeek + handle + IO.AbsoluteSeek + (fromIntegral byteOffset) + got <- IO.hGetBuf handle ptr (fromIntegral byteLength) + pure $ fromIntegral got == byteLength + +instance Show (Context IO.Handle) where + show (Context handle header) = mconcat + [ "Context (" + , show handle + , ") " + , show header + ] + +open :: MonadIO io => FilePath -> io FileContext +open path = do + handle <- liftIO $ IO.openBinaryFile path IO.ReadMode + header <- decodeAt handle 0 80 get + pure $ Context handle header + +close :: MonadIO io => FileContext -> io () +close (Context handle _header) = liftIO $ IO.hClose handle + +-- ** Reading from memory + +-- | Context for reading from memory. Useful when the data is embedded in a module or otherwise already available in full. +type BytesContext = Context ByteString + +instance ReadChunk ByteString where + readChunkAt bs offset size = + if offset + size > BS.length bs then + liftIO . throwIO . ChunkError $ mconcat + [ "Offset " <> fromString (show offset) + , " and size " <> fromString (show size) + , " is beyond the size of the buffer: " + , fromString (show $ BS.length bs) + ] + else + pure $ BS.take size (BS.drop offset bs) + +instance ReadLevel ByteString where + readLevelTo buf Level{..} dst = + liftIO $ BSU.unsafeUseAsCStringLen buf \(src, size) -> + if size < fromIntegral (byteOffset + byteLength) then + pure False + else do + Foreign.copyBytes + dst + (plusPtr src $ fromIntegral byteOffset) + (fromIntegral byteLength) + pure True + +instance Show (Context ByteString) where + show (Context buf header) = mconcat + [ "Context [" + , show $ BS.length buf + , "] " + , show header + ] + +bytes :: MonadIO io => ByteString -> io BytesContext +bytes src = do + header <- decodeAt src 0 80 get + pure $ Context src header + +-- * File contents + +-- | Read the level index. +levels + :: ( ReadChunk src + , MonadIO io + ) + => Context src + -> io (Vector Level) +levels (Context handle Header{levelCount}) = + decodeAt handle 80 (numLevels * 8 * 3) $ + Vector.replicateM numLevels get + where + numLevels = max 1 $ fromIntegral levelCount + +{- | Copy level data into a provided pointer. + +The buffer must be large enough for the 'byteLength' of the "Level" being accessed. +-} +{-# INLINE levelToPtr #-} +levelToPtr + :: ( ReadLevel src + , MonadIO io + ) + => Context src + -> Level + -> Ptr () + -> io Bool +levelToPtr (Context handle _header) = readLevelTo handle + +-- | Copy level data into a managed buffer. +levelData + :: ( ReadChunk src + , MonadIO io + ) + => Context src + -> Level + -> io ByteString +levelData (Context handle _header) Level{..} = do + readChunkAt + handle + (fromIntegral byteOffset) + (fromIntegral byteLength) + +{- | Read DFD block data. + +Further processing is performed according to descriptor vendor/type/version. +E.g. "Codec.Ktx2.DFD.Khronos.BasicV2". +-} +dataFormatDescriptor + :: ( ReadChunk src + , MonadIO io + ) + => Context src + -> io DFD +dataFormatDescriptor (Context handle Header{..}) = + decodeAt + handle + (fromIntegral dfdByteOffset) + (fromIntegral dfdByteLength) + get + +{- | Read and parse Key-Value Data block. +-} +keyValueData + :: ( ReadChunk src + , MonadIO io + ) + => Context src + -> io KeyValueData +keyValueData (Context handle Header{..}) = + decodeAt + handle + (fromIntegral kvdByteOffset) + (fromIntegral kvdByteLength) + (KeyValue.getDataLe $ fromIntegral kvdByteLength) + +-- | Get a copy of global supercompression data. +supercompressionGlobalData + :: ( ReadChunk src + , MonadIO io + ) + => Context src + -> io ByteString +supercompressionGlobalData (Context handle Header{..}) = + decodeAt + handle + (fromIntegral sgdByteOffset) + (fromIntegral sgdByteLength) + (getByteString $ fromIntegral sgdByteLength) + +-- * IO helpers + +class ReadChunk a where + {- | Get a chunk of data. + + The context handle must have enough information to check whether requested region is safe to access. + Throw "ChunkError" when it isn't possible to fullfill the request. + -} + readChunkAt :: MonadIO io => a -> Int -> Int -> io ByteString + +newtype ChunkError = ChunkError Text + deriving (Eq, Show) + +instance Exception ChunkError + +-- | Get a chunk of data and run a decoder on it. +decodeAt + :: ( ReadChunk src + , Show a + , MonadIO io + ) + => src + -> Int + -> Int + -> Get a + -> io a +decodeAt src offset size action = do + chunk <- readChunkAt src offset size + case runGetOrFail action (BSL.fromChunks [chunk]) of + Right ("", used, ok) | fromIntegral used == size -> + pure ok + Right (remains, finalOffset, _okBut) -> + liftIO . throwIO $ DecodeError finalOffset $ + "BUG: unused data" <> fromString (show remains) + Left (_remains, errorOffset, message) -> + liftIO . throwIO $ DecodeError errorOffset (fromString message) + +data DecodeError = DecodeError ByteOffset Text + deriving (Eq, Show) + +instance Exception DecodeError + +class ReadLevel a where + readLevelTo :: MonadIO io => a -> Level -> Ptr () -> io Bool diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,16 +1,29 @@ module Main where +import Codec.Compression.Zstd.FFI qualified as Zstd +import Control.Exception (bracket) import Control.Monad (guard, unless) +import Data.ByteString qualified as BS +import Data.ByteString.Builder (toLazyByteString) +import Data.ByteString.Lazy qualified as BSL import Data.List (isSuffixOf) +import Data.Vector qualified as Vector import Debug.Trace (traceM) -import Shower (printer) +import Foreign qualified +import Shower qualified import System.Directory (listDirectory) +import System.Environment (lookupEnv) import System.FilePath (()) -import Data.ByteString.Builder (Builder, toLazyByteString) - -import qualified Data.ByteString.Lazy as BSL +import Test.Tasty +import Test.Tasty.HUnit -import qualified Codec.Ktx as Ktx1 +import Codec.Ktx qualified as Ktx1 +import Codec.Ktx.KeyValue qualified as KeyValue +import Codec.Ktx2.DFD (DFD(..)) +import Codec.Ktx2.DFD.Khronos.BasicV2 qualified as BasicV2 +import Codec.Ktx2.Header qualified as Header +import Codec.Ktx2.Level qualified as Level +import Codec.Ktx2.Read qualified as Read assetsPath :: FilePath assetsPath = ".." "assets" @@ -18,11 +31,24 @@ main :: IO () main = do assets <- listDirectory assetsPath - - mapM_ testKtx1 do - fp <- assets - guard $ ".ktx" `isSuffixOf` fp - pure $ assetsPath fp + defaultMain $ + testGroup "ktx-codec" + [ testGroup "KTX 1" do + fp <- assets + guard $ ".ktx" `isSuffixOf` fp + pure . testCase fp $ + testKtx1 (assetsPath fp) + , testGroup "KTX 2 (files)" do + fp <- assets + guard $ ".ktx2" `isSuffixOf` fp + pure . testCase fp $ + testKtx2File (assetsPath fp) + , testGroup "KTX 2 (bytes)" do + fp <- assets + guard $ ".ktx2" `isSuffixOf` fp + pure . testCase fp $ + testKtx2Bytes (assetsPath fp) + ] testKtx1 :: FilePath -> IO () testKtx1 source = @@ -41,3 +67,89 @@ originalBytes <- BSL.readFile source unless (encodedBytes == originalBytes) $ fail $ "Encoded KTX does not match original for " <> source + +testKtx2File :: FilePath -> IO () +testKtx2File source = + bracket (Read.open source) Read.close $ + testKtx2Context source + +testKtx2Bytes :: FilePath -> IO () +testKtx2Bytes source = do + contents <- BS.readFile source + Read.bytes contents >>= testKtx2Context source + +testKtx2Context + :: ( Read.ReadChunk a + , Read.ReadLevel a + , Show (Read.Context a) + ) + => FilePath + -> Read.Context a + -> IO () +testKtx2Context source ctx = do + printer ctx + + levels <- Read.levels ctx + printer levels + + DFD{dfdBlocks} <- Read.dataFormatDescriptor ctx + block0 <- Vector.headM dfdBlocks + case BasicV2.fromBlock block0 of + Nothing -> do + printer block0 + fail $ "Unexpected block type in test suite in " <> source + Just basic -> do + -- printer basic + let back = BasicV2.toBlock basic + unless (back == block0) do + printer (back, block0) + fail "BasicV2 tripping failed" + + fmap KeyValue.textual (Read.keyValueData ctx) >>= Shower.printer + Read.supercompressionGlobalData ctx >>= printer + Vector.forM_ levels \level -> do + bytes <- Read.levelData ctx level + unless (BS.length bytes == fromIntegral (Level.byteLength level)) $ + fail "Uncompressed level data does not match with index!" + + Foreign.allocaBytesAligned (fromIntegral $ Level.uncompressedByteLength level) 16 \dst -> do + case Header.supercompressionScheme (Read.header ctx) of + Header.SC_NONE -> do + -- XXX: Write to destination directly + ok <- Read.levelToPtr ctx level dst + unless ok $ + fail $ "Data read failed for " <> show level + + Header.SC_ZSTANDARD -> + -- XXX: Prepare an intermediate buffer for decompression + Foreign.allocaBytesAligned (fromIntegral $ Level.byteLength level) 16 \stage -> do + ok <- Read.levelToPtr ctx level stage + unless ok $ + fail $ "Data read failed for " <> show level + + let expected = fromIntegral $ Level.uncompressedByteLength level + res <- + Zstd.checkError $ + Zstd.decompress + dst + expected + stage + (fromIntegral $ Level.byteLength level) + case res of + Right decoded | decoded == expected -> + printer (decoded, level) + Right mismatch -> + fail $ "Zstd decoded unexpected number of bytes (" <> show mismatch <> ") for level " <> show level + Left err -> + fail $ "Zstd error: " <> err + + huh -> + fail $ "Unexpected supercompression: " <> show huh + +printer :: Show a => a -> IO () +printer x = + lookupEnv "TEST_DUMP" >>= \case + Nothing -> + pure () + Just _ -> + Shower.printer x