diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,14 @@ +# Changelog for `gltf-codec` + +## Unreleased changes + +## [0.1.0.1] - 2020-06-21 + +* Added pattern synonyms for newtyped "allowed values". + +## [0.1.0.0] - 2020-06-07 + +* Initial import. + +[0.1.0.1]: https://gitlab.com/dpwiz/gltf/tree/v0.1.0.1 +[0.1.0.0]: https://gitlab.com/dpwiz/gltf/tree/v0.1.0.0 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Alexander Bondarenko (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alexander Bondarenko nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# gltf diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/gltf-codec.cabal b/gltf-codec.cabal new file mode 100644 --- /dev/null +++ b/gltf-codec.cabal @@ -0,0 +1,85 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: d999cb91b06d0be5cac1d0bcc4f794a7d8acb692a0265b6b8642b4fb7366c33f + +name: gltf-codec +version: 0.1.0.1 +synopsis: glTF scene loader +description: The package provides basic types to process JSON and "binary" files. + No further conversion is performed to keep dependencies to a minimum. +category: Graphics +author: Alexander Bondarenko +maintainer: aenor.realm@gmail.com +copyright: 2020 Alexander Bondarenko +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://gitlab.com/dpwiz/gltf + +library + exposed-modules: + Codec.GLB + Codec.GlTF + Codec.GlTF.Accessor + Codec.GlTF.Animation + Codec.GlTF.Asset + Codec.GlTF.Buffer + Codec.GlTF.BufferView + Codec.GlTF.Camera + Codec.GlTF.Image + Codec.GlTF.Material + Codec.GlTF.Mesh + Codec.GlTF.Node + Codec.GlTF.PbrMetallicRoughness + Codec.GlTF.Prelude + Codec.GlTF.Root + Codec.GlTF.Sampler + Codec.GlTF.Scene + Codec.GlTF.Skin + Codec.GlTF.Texture + Codec.GlTF.TextureInfo + Codec.GlTF.URI + other-modules: + Paths_gltf_codec + hs-source-dirs: + src + default-extensions: ApplicativeDo BlockArguments DeriveGeneric DuplicateRecordFields FlexibleContexts GeneralizedNewtypeDeriving LambdaCase OverloadedStrings PatternSynonyms RecordWildCards StrictData + build-depends: + aeson >=1.4 && <1.5 + , base >=4.7 && <5 + , base64-bytestring >=1 && <2 + , binary >=0.8.7 && <1 + , bytestring >=0.10 && <0.11 + , scientific >=0.3.6 && <0.4 + , text >=1.2 && <1.3 + , unordered-containers >=0.2.10 && <0.3 + , vector >=0.12 && <0.13 + default-language: Haskell2010 + +test-suite gltf-codec-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_gltf_codec + hs-source-dirs: + test + default-extensions: ApplicativeDo BlockArguments DeriveGeneric DuplicateRecordFields FlexibleContexts GeneralizedNewtypeDeriving LambdaCase OverloadedStrings PatternSynonyms RecordWildCards StrictData + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , bytestring >=0.10 && <0.11 + , directory >=1.3 && <1.4 + , filepath >=1.4 && <1.5 + , gltf-codec + , shower >=0.2 && <0.3 + default-language: Haskell2010 diff --git a/src/Codec/GLB.hs b/src/Codec/GLB.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GLB.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} + +module Codec.GLB where + +import Prelude hiding (length) + +import Data.Binary (Binary(..), decodeFileOrFail) +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) + +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 diff --git a/src/Codec/GlTF.hs b/src/Codec/GlTF.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GlTF.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Codec.GlTF + ( GlTF(..) + , fromFile + , fromChunk + ) where + +import qualified Data.Aeson as JSON + +import Codec.GlTF.Root (GlTF(..)) + +import qualified Codec.GLB as GLB + +fromFile :: FilePath -> IO (Either String GlTF) +fromFile = JSON.eitherDecodeFileStrict' + +fromChunk :: GLB.Chunk -> Either String GlTF +fromChunk = JSON.eitherDecodeStrict' . GLB.chunkData diff --git a/src/Codec/GlTF/Accessor.hs b/src/Codec/GlTF/Accessor.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GlTF/Accessor.hs @@ -0,0 +1,145 @@ +module Codec.GlTF.Accessor + ( AccessorIx(..) + , Accessor(..) + + , AccessorSparse(..) + , AccessorSparseIndices(..) + , AccessorSparseValues(..) + + , ComponentType(..) + , pattern BYTE + , pattern UNSIGNED_BYTE + , pattern SHORT + , pattern UNSIGNED_SHORT + , pattern UNSIGNED_INT + , pattern FLOAT + + , AttributeType(..) + , pattern SCALAR + , pattern VEC2 + , pattern VEC3 + , pattern VEC4 + , pattern MAT2 + , pattern MAT3 + , pattern MAT4 + ) where + +import Prelude hiding (min, max) +import Codec.GlTF.Prelude + +import Codec.GlTF.BufferView (BufferViewIx) + +newtype AccessorIx = AccessorIx { unAccessorIx :: Int } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +-- | The root object for a glTF Accessor. +data Accessor = Accessor + { componentType :: ComponentType + , normalized :: Bool + , byteOffset :: Size + , count :: Size + , type' :: AttributeType + + , bufferView :: Maybe BufferViewIx + , min :: Maybe (Vector Scientific) + , max :: Maybe (Vector Scientific) + , sparse :: Maybe AccessorSparse + + , name :: Maybe Text + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON Accessor where + parseJSON = withObject "Accessor" \o -> do + bufferView <- o .:? "bufferView" + byteOffset <- o .:? "byteOffset" .!= 0 + componentType <- o .: "componentType" + normalized <- o .:? "normalized" .!= False + count <- o .: "count" + type' <- o .: "type" + min <- o .:? "min" + max <- o .:? "max" + sparse <- o .:? "sparse" + name <- o .:? "name" + extensions <- o .:? "extensions" + extras <- o .:? "extras" + pure Accessor{..} + +instance ToJSON Accessor where + toJSON = gToJSON + +newtype ComponentType = ComponentType { unComponentType :: Int } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +pattern BYTE :: ComponentType +pattern BYTE = ComponentType 5120 + +pattern UNSIGNED_BYTE :: ComponentType +pattern UNSIGNED_BYTE = ComponentType 5121 + +pattern SHORT :: ComponentType +pattern SHORT = ComponentType 5122 + +pattern UNSIGNED_SHORT :: ComponentType +pattern UNSIGNED_SHORT = ComponentType 5123 + +pattern UNSIGNED_INT :: ComponentType +pattern UNSIGNED_INT = ComponentType 5125 + +pattern FLOAT :: ComponentType +pattern FLOAT = ComponentType 5126 + +newtype AttributeType = AttributeType { unAttributeType :: Text } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +pattern SCALAR :: AttributeType +pattern SCALAR = AttributeType "SCALAR" + +pattern VEC2 :: AttributeType +pattern VEC2 = AttributeType "VEC2" + +pattern VEC3 :: AttributeType +pattern VEC3 = AttributeType "VEC3" + +pattern VEC4 :: AttributeType +pattern VEC4 = AttributeType "VEC4" + +pattern MAT2 :: AttributeType +pattern MAT2 = AttributeType "MAT2" + +pattern MAT3 :: AttributeType +pattern MAT3 = AttributeType "MAT3" + +pattern MAT4 :: AttributeType +pattern MAT4 = AttributeType "MAT4" + +-- | Sparse storage of attributes that deviate from their initialization value. +data AccessorSparse = AccessorSparse + { count :: Size + , indices :: AccessorSparseIndices + , values :: AccessorSparseValues + } deriving (Eq, Show, Generic) + +instance FromJSON AccessorSparse +instance ToJSON AccessorSparse + +-- | Indices of those attributes that deviate from their initialization value. +data AccessorSparseIndices = AccessorSparseIndices + { bufferView :: Maybe BufferViewIx + , byteOffset :: Size + , componentType :: ComponentType + } deriving (Eq, Show, Generic) + +instance FromJSON AccessorSparseIndices +instance ToJSON AccessorSparseIndices + +-- | Array of size @accessor.sparse.count@ times number of components storing +-- the displaced accessor attributes pointed by @accessor.sparse.indices@. +data AccessorSparseValues = AccessorSparseValues + { bufferView :: Maybe BufferViewIx + , byteOffset :: Size + } deriving (Eq, Show, Generic) + +instance FromJSON AccessorSparseValues +instance ToJSON AccessorSparseValues diff --git a/src/Codec/GlTF/Animation.hs b/src/Codec/GlTF/Animation.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GlTF/Animation.hs @@ -0,0 +1,126 @@ +module Codec.GlTF.Animation + ( AnimationIx(..) + , Animation(..) + + , AnimationSamplerIx(..) + , AnimationSampler(..) + , AnimationSamplerInterpolation(..) + , pattern LINEAR + , pattern STEP + , pattern CUBICSPLINE + + , AnimationChannel(..) + + , AnimationChannelTarget(..) + , AnimationChannelTargetPath(..) + , pattern TRANSLATION + , pattern ROTATION + , pattern SCALE + , pattern WEIGHTS + ) where + +import Codec.GlTF.Prelude + +import Codec.GlTF.Accessor (AccessorIx) +import Codec.GlTF.Node (NodeIx) + +newtype AnimationIx = AnimationIx { unAnimationIx :: Int } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +-- | A keyframe animation. +data Animation = Animation + { channels :: Vector AnimationChannel + , samplers :: Vector AnimationSampler + + , name :: Maybe Text + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON Animation +instance ToJSON Animation + +newtype AnimationSamplerIx = AnimationSamplerIx { unAnimationSamplerIx :: Int } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +-- | Combines input and output accessors with an interpolation algorithm +-- to define a keyframe graph (but not its target). +data AnimationSampler = AnimationSampler + { input :: AccessorIx + -- ^ The values represent time in seconds with @time[0] >= 0.0@, + -- and strictly increasing values. + , interpolation :: AnimationSamplerInterpolation + , output :: AccessorIx + -- ^ The index of an accessor containing keyframe output values. + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON AnimationSampler where + parseJSON = withObject "AnimationSampler" \o -> do + input <- o .: "input" + interpolation <- o .:? "interpolation" .!= LINEAR + output <- o .: "output" + extensions <- o .:? "extensions" + extras <- o .:? "extras" + + pure AnimationSampler{..} + +instance ToJSON AnimationSampler + +newtype AnimationSamplerInterpolation = AnimationSamplerInterpolation { unAnimationSamplerInterpolation :: Text } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +pattern LINEAR :: AnimationSamplerInterpolation +pattern LINEAR = AnimationSamplerInterpolation "LINEAR" + +pattern STEP :: AnimationSamplerInterpolation +pattern STEP = AnimationSamplerInterpolation "STEP" + +pattern CUBICSPLINE :: AnimationSamplerInterpolation +pattern CUBICSPLINE = AnimationSamplerInterpolation "CUBICSPLINE" + +-- | Targets an animation's sampler at a node's property. +data AnimationChannel = AnimationChannel + { sampler :: AnimationSamplerIx + , target :: AnimationChannelTarget + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON AnimationChannel +instance ToJSON AnimationChannel + +-- | The index of the node and TRS property that an animation channel targets. +data AnimationChannelTarget = AnimationChannelTarget + { node :: Maybe NodeIx + , path :: AnimationChannelTargetPath + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON AnimationChannelTarget +instance ToJSON AnimationChannelTarget + +-- | The name of the node's TRS property to modify, or the @weights@ of +-- the Morph Targets it instantiates. +-- For the @translation@ property, the values that are provided by +-- the sampler are the translation along the x, y, and z axes. +-- For the @rotation@ property, the values are a quaternion in +-- the order (x, y, z, w), where w is the scalar. +-- For the @scale@ property, the values are the scaling factors +-- along the x, y, and z axes.", +newtype AnimationChannelTargetPath = AnimationChannelTargetPath { unAnimationChannelTargetPath :: Text } -- XXX: T/R/S/weights/any + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +pattern TRANSLATION :: AnimationChannelTargetPath +pattern TRANSLATION = AnimationChannelTargetPath "translation" + +pattern ROTATION :: AnimationChannelTargetPath +pattern ROTATION = AnimationChannelTargetPath "rotation" + +pattern SCALE :: AnimationChannelTargetPath +pattern SCALE = AnimationChannelTargetPath "scale" + +pattern WEIGHTS :: AnimationChannelTargetPath +pattern WEIGHTS = AnimationChannelTargetPath "weights" diff --git a/src/Codec/GlTF/Asset.hs b/src/Codec/GlTF/Asset.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GlTF/Asset.hs @@ -0,0 +1,16 @@ +module Codec.GlTF.Asset where + +import Codec.GlTF.Prelude + +-- | Metadata about the glTF asset. +data Asset = Asset + { version :: Text + , copyright :: Maybe Text + , generator :: Maybe Text + , minVersion :: Maybe Text + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON Asset +instance ToJSON Asset diff --git a/src/Codec/GlTF/Buffer.hs b/src/Codec/GlTF/Buffer.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GlTF/Buffer.hs @@ -0,0 +1,28 @@ +module Codec.GlTF.Buffer + ( BufferIx(..) + , Buffer(..) + ) where + +import Codec.GlTF.Prelude + +import Codec.GlTF.URI (URI) + +newtype BufferIx = BufferIx { unBufferIx :: Int } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +-- | A buffer points to binary geometry, animation, or skins. +-- +-- glTF Buffer referring to GLB-stored BIN chunk, must have @buffer.uri@ +-- property undefined, and it must be the first element of buffers array; +-- byte length of BIN chunk could be up to 3 bytes bigger than JSON-defined +-- buffer.byteLength to satisfy GLB padding requirements. +data Buffer = Buffer + { byteLength :: Size + , uri :: Maybe URI + , name :: Maybe Text + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON Buffer +instance ToJSON Buffer diff --git a/src/Codec/GlTF/BufferView.hs b/src/Codec/GlTF/BufferView.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GlTF/BufferView.hs @@ -0,0 +1,53 @@ +module Codec.GlTF.BufferView + ( BufferViewIx(..) + , BufferView(..) + , BufferViewTarget(..) + , pattern ARRAY_BUFFER + , pattern ELEMENT_ARRAY_BUFFER + ) where + +import Codec.GlTF.Prelude + +import Codec.GlTF.Buffer (BufferIx) + +newtype BufferViewIx = BufferViewIx { unBufferViewIx :: Int } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +-- | A view into a buffer generally representing a subset of the buffer. +data BufferView = BufferView + { buffer :: BufferIx + , byteOffset :: Size + , byteLength :: Size + , byteStride :: Maybe Size -- [4-252] + -- ^ The stride, in bytes, between vertex attributes. + -- When this is not defined, data is tightly packed. + -- When two or more accessors use the same bufferView, this field must be defined. + , target :: Maybe BufferViewTarget + -- ^ The target that the GPU buffer should be bound to. + , name :: Maybe Text + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON BufferView where + parseJSON = withObject "BufferView" \o -> do + buffer <- o .: "buffer" + byteOffset <- o .:? "byteOffset" .!= 0 + byteLength <- o .: "byteLength" + byteStride <- o .:? "byteStride" + target <- o .:? "target" + name <- o .:? "name" + extensions <- o .:? "extensions" + extras <- o .:? "extras" + pure BufferView{..} + +instance ToJSON BufferView + +newtype BufferViewTarget = BufferViewTarget { unBufferViewTarget :: Int } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +pattern ARRAY_BUFFER :: BufferViewTarget +pattern ARRAY_BUFFER = BufferViewTarget 34962 + +pattern ELEMENT_ARRAY_BUFFER :: BufferViewTarget +pattern ELEMENT_ARRAY_BUFFER = BufferViewTarget 34963 diff --git a/src/Codec/GlTF/Camera.hs b/src/Codec/GlTF/Camera.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GlTF/Camera.hs @@ -0,0 +1,68 @@ +module Codec.GlTF.Camera + ( CameraIx(..) + , Camera(..) + , CameraType(..) + , pattern PERSPECTIVE + , pattern ORTHOGRAPHIC + + , CameraPerspective(..) + , CameraOrthographic(..) + ) where + +import Codec.GlTF.Prelude + +newtype CameraIx = CameraIx { unCameraIx :: Int } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +-- | A camera's projection. +-- +-- A node can reference a camera to apply a transform to place the camera in the scene. +data Camera = Camera + { type' :: CameraType + , perspective :: Maybe CameraPerspective + , orthographic :: Maybe CameraOrthographic + , name :: Maybe Text + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON Camera where + parseJSON = gParseJSON + +instance ToJSON Camera where + toJSON = gToJSON + +newtype CameraType = CameraType { unCameraType :: Text } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +pattern PERSPECTIVE :: CameraType +pattern PERSPECTIVE = CameraType "perspective" + +pattern ORTHOGRAPHIC :: CameraType +pattern ORTHOGRAPHIC = CameraType "orthographic" + +-- | A perspective camera containing properties to create a perspective projection matrix. +data CameraPerspective = CameraPerspective + { yfov :: Float + , znear :: Float + , aspectRatio :: Maybe Float + , zfar :: Maybe Float + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON CameraPerspective +instance ToJSON CameraPerspective + +-- | An orthographic camera containing properties to create an orthographic projection matrix. +data CameraOrthographic = CameraOrthographic + { xmag :: Float + , ymag :: Float + , zfar :: Float + , znear :: Float + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON CameraOrthographic +instance ToJSON CameraOrthographic diff --git a/src/Codec/GlTF/Image.hs b/src/Codec/GlTF/Image.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GlTF/Image.hs @@ -0,0 +1,28 @@ +module Codec.GlTF.Image + ( ImageIx(..) + , Image(..) + ) where + +import Codec.GlTF.Prelude + +import Codec.GlTF.BufferView (BufferViewIx) +import Codec.GlTF.URI (URI) + +newtype ImageIx = ImageIx { unImageIx :: Int } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +-- | Image data used to create a texture. +-- +-- Image can be referenced by URI or bufferView index. +-- @mimeType@ is required in the latter case. +data Image = Image + { uri :: Maybe URI + , mimeType :: Maybe Text + , bufferView :: Maybe BufferViewIx + , name :: Maybe Text + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON Image +instance ToJSON Image diff --git a/src/Codec/GlTF/Material.hs b/src/Codec/GlTF/Material.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GlTF/Material.hs @@ -0,0 +1,91 @@ +module Codec.GlTF.Material + ( MaterialIx(..) + , Material(..) + , MaterialAlphaMode(..) + , pattern OPAQUE + , pattern MASK + , pattern BLEND + , MaterialNormal(..) + , MaterialOcclusion(..) + ) where + +import Codec.GlTF.Prelude + +import Codec.GlTF.PbrMetallicRoughness (PbrMetallicRoughness) +import Codec.GlTF.TextureInfo (TextureInfo, TextureInfo_) + +newtype MaterialIx = MaterialIx { unMaterialIx :: Int } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +-- | The material appearance of a primitive. +data Material = Material + { emissiveFactor :: (Float, Float, Float) + , alphaMode :: MaterialAlphaMode + , alphaCutoff :: Float + , doubleSided :: Bool + + , pbrMetallicRoughness :: Maybe PbrMetallicRoughness + , normalTexture :: Maybe (TextureInfo MaterialNormal) + , occlusionTexture :: Maybe (TextureInfo MaterialOcclusion) + , emissiveTexture :: Maybe (TextureInfo_) + + , name :: Maybe Text + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON Material where + parseJSON = withObject "Material" \o -> do + emissiveFactor <- o .:? "emissiveFactor" .!= (0, 0, 0) + alphaMode <- o .:? "alphaMode" .!= OPAQUE + alphaCutoff <- o .:? "alphaCutoff" .!= 0.5 + doubleSided <- o .:? "doubleSided" .!= False + + pbrMetallicRoughness <- o .:? "pbrMetallicRoughness" + normalTexture <- o .:? "normalTexture" + occlusionTexture <- o .:? "occlusionTexture" + emissiveTexture <- o .:? "emissiveTexture" + + name <- o .:? "name" + extensions <- o .:? "extensions" + extras <- o .:? "extras" + pure Material{..} + +instance ToJSON Material + +-- | The alpha rendering mode of the material. +newtype MaterialAlphaMode = MaterialAlphaMode { unMaterialAlphaMode :: Text } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +pattern OPAQUE :: MaterialAlphaMode +pattern OPAQUE = MaterialAlphaMode "OPAQUE" + +pattern MASK :: MaterialAlphaMode +pattern MASK = MaterialAlphaMode "MASK" + +pattern BLEND :: MaterialAlphaMode +pattern BLEND = MaterialAlphaMode "BLEND" + +data MaterialNormal = MaterialNormal + { scale :: Float + -- ^ The scalar multiplier applied to each normal vector of the normal texture. + } deriving (Eq, Show, Generic) + +instance FromJSON MaterialNormal where + parseJSON = withObject "MaterialNormal" \o -> do + scale <- o .:? "scale" .!= 1.0 + pure MaterialNormal{..} + +instance ToJSON MaterialNormal + +data MaterialOcclusion = MaterialOcclusion + { strength :: Float + -- ^ A scalar multiplier controlling the amount of occlusion applied. @[0.0-1.0]@ + } deriving (Eq, Show, Generic) + +instance FromJSON MaterialOcclusion where + parseJSON = withObject "MaterialOcclusion" \o -> do + strength <- o .:? "strength" .!= 1.0 + pure MaterialOcclusion{..} + +instance ToJSON MaterialOcclusion diff --git a/src/Codec/GlTF/Mesh.hs b/src/Codec/GlTF/Mesh.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GlTF/Mesh.hs @@ -0,0 +1,93 @@ +module Codec.GlTF.Mesh + ( MeshIx(..) + , Mesh(..) + + , MeshPrimitive(..) + , MeshPrimitiveMode(..) + , pattern POINTS + , pattern LINES + , pattern LINE_LOOP + , pattern LINE_STRIP + , pattern TRIANGLES + , pattern TRIANGLE_STRIP + , pattern TRIANGLE_FAN + ) where + +import Codec.GlTF.Prelude + +import Codec.GlTF.Accessor (AccessorIx) +import Codec.GlTF.Material (MaterialIx) + +newtype MeshIx = MeshIx { unMeshIx :: Int } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +-- | A set of primitives to be rendered. +-- +-- A node can contain one mesh. A node's transform places the mesh in the scene. +data Mesh = Mesh + { primitives :: Vector MeshPrimitive + , weights :: Maybe (Vector Float) + , name :: Maybe Text + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON Mesh where + parseJSON = withObject "Mesh" \o -> do + primitives <- o .: "primitives" + weights <- o .:? "weights" + name <- o .:? "name" + extensions <- o .:? "extensions" + extras <- o .:? "extras" + pure Mesh{..} + +instance ToJSON Mesh + +-- | Geometry to be rendered with the given material. +data MeshPrimitive = MeshPrimitive + { attributes :: HashMap Text AccessorIx + , mode :: MeshPrimitiveMode + , indices :: Maybe AccessorIx + , material :: Maybe MaterialIx + , targets :: Maybe (Vector (HashMap Text AccessorIx)) + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON MeshPrimitive where + parseJSON = withObject "MeshPrimitive" \o -> do + attributes <- o .: "attributes" + mode <- o .:? "mode" .!= TRIANGLES + indices <- o .:? "indices" + material <- o .:? "material" + targets <- o .:? "targets" + extensions <- o .:? "extensions" + extras <- o .:? "extras" + pure MeshPrimitive{..} + +instance ToJSON MeshPrimitive + +-- | The type of primitives to render. +newtype MeshPrimitiveMode = MeshPrimitiveMode { unMeshPrimitiveMode :: Int } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +pattern POINTS :: MeshPrimitiveMode +pattern POINTS = MeshPrimitiveMode 0 + +pattern LINES :: MeshPrimitiveMode +pattern LINES = MeshPrimitiveMode 1 + +pattern LINE_LOOP :: MeshPrimitiveMode +pattern LINE_LOOP = MeshPrimitiveMode 2 + +pattern LINE_STRIP :: MeshPrimitiveMode +pattern LINE_STRIP = MeshPrimitiveMode 3 + +pattern TRIANGLES :: MeshPrimitiveMode +pattern TRIANGLES = MeshPrimitiveMode 4 + +pattern TRIANGLE_STRIP :: MeshPrimitiveMode +pattern TRIANGLE_STRIP = MeshPrimitiveMode 5 + +pattern TRIANGLE_FAN :: MeshPrimitiveMode +pattern TRIANGLE_FAN = MeshPrimitiveMode 6 diff --git a/src/Codec/GlTF/Node.hs b/src/Codec/GlTF/Node.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GlTF/Node.hs @@ -0,0 +1,73 @@ +module Codec.GlTF.Node + ( NodeIx(..) + , Node(..) + , NodeMatrix(..) + + -- XXX: Misplaced here due to mutual recursion. + , SkinIx(..) + , Skin(..) + ) where + +import Codec.GlTF.Prelude + +import Codec.GlTF.Accessor (AccessorIx) +import Codec.GlTF.Camera (CameraIx) +import Codec.GlTF.Mesh (MeshIx) + +newtype NodeIx = NodeIx { unNodeIx :: Int } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +-- | A node in the node hierarchy. +-- +-- When the node contains skin, all mesh.primitives must contain JOINTS_0 and WEIGHTS_0 attributes. +-- +-- A node can have either a matrix or any combination of translation/rotation/scale (TRS) properties. +-- +-- TRS properties are converted to matrices and postmultiplied in the T * R * S order to +-- compose the transformation matrix; first the scale is applied to the vertices, then +-- the rotation, and then the translation. +-- If none are provided, the transform is the identity. +-- +-- When a node is targeted for animation (referenced by an animation.channel.target), +-- only TRS properties may be present; matrix will not be present. +data Node = Node + { camera :: Maybe CameraIx + , children :: Maybe (Vector NodeIx) + , skin :: Maybe SkinIx + , matrix :: Maybe NodeMatrix + , mesh :: Maybe MeshIx + , rotation :: Maybe (Float, Float, Float, Float) + , scale :: Maybe (Float, Float, Float) + , translation :: Maybe (Float, Float, Float) + , weights :: Maybe (Vector Float) + , name :: Maybe Text + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON Node +instance ToJSON Node + +-- | A floating-point 4x4 transformation matrix stored in column-major order. +newtype NodeMatrix = NodeMatrix { unNodeMatrix :: Vector Float } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +newtype SkinIx = SkinIx { unSkinIx :: Int } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +-- | Joints and matrices defining a skin. +data Skin = Skin + { joints :: Vector (NodeIx) + , skeleton :: Maybe NodeIx + , inverseBindMatrices :: Maybe AccessorIx + -- ^ The index of the accessor containing the floating-point + -- 4x4 inverse-bind matrices. + -- The default is that each matrix is a 4x4 identity matrix, + -- which implies that inverse-bind matrices were pre-applied. + , name :: Maybe Text + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON Skin +instance ToJSON Skin diff --git a/src/Codec/GlTF/PbrMetallicRoughness.hs b/src/Codec/GlTF/PbrMetallicRoughness.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GlTF/PbrMetallicRoughness.hs @@ -0,0 +1,34 @@ +module Codec.GlTF.PbrMetallicRoughness + ( PbrMetallicRoughness(..) + ) where + +import Codec.GlTF.Prelude + +import Codec.GlTF.TextureInfo (TextureInfo_) + +-- | A set of parameter values that are used to define the metallic-roughness +-- material model from Physically-Based Rendering (PBR) methodology. +data PbrMetallicRoughness = PbrMetallicRoughness + { baseColorFactor :: (Float, Float, Float, Float) + , metallicFactor :: Float + , roughnessFactor :: Float + , metallicRoughnessTexture :: Maybe TextureInfo_ + , baseColorTexture :: Maybe TextureInfo_ + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON PbrMetallicRoughness where + parseJSON = withObject "PbrMetallicRoughness" \o -> do + baseColorFactor <- o .:? "baseColorFactor" .!= (1.0, 1.0, 1.0, 1.0) + metallicFactor <- o .:? "metallicFactor" .!= 1.0 + roughnessFactor <- o .:? "roughnessFactor" .!= 1.0 + + metallicRoughnessTexture <- o .:? "metallicRoughnessTexture" + baseColorTexture <- o .:? "baseColorTexture" + + extensions <- o .:? "extensions" + extras <- o .:? "extras" + pure PbrMetallicRoughness{..} + +instance ToJSON PbrMetallicRoughness diff --git a/src/Codec/GlTF/Prelude.hs b/src/Codec/GlTF/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GlTF/Prelude.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE PartialTypeSignatures #-} + +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + +module Codec.GlTF.Prelude + ( Size + + , FromJSON(..) + , ToJSON(..) + , Generic + , gParseJSON + , gToJSON + + , HashMap + , Object + , Scientific + , Text + , Value + , Vector + + , withText + , withObject + , (.:) + , (.:?) + , (.!=) + ) where + +import Data.Aeson (FromJSON(..), ToJSON(..), Value, Object, withText, withObject, (.:), (.:?), (.!=)) +import Data.Aeson.Types (Parser, Options(..), defaultOptions, genericParseJSON, genericToJSON) +import Data.List (dropWhileEnd) +import Data.Scientific (Scientific) +import Data.Text (Text) +import Data.Vector (Vector) +import Data.HashMap.Strict (HashMap) +import GHC.Generics (Generic) + +type Size = Int + +gParseJSON :: _ => Value -> Parser a +gParseJSON = genericParseJSON dropEndTick + +gToJSON :: _ => a -> Value +gToJSON = genericToJSON dropEndTick + +dropEndTick :: Options +dropEndTick = defaultOptions + { fieldLabelModifier = dropWhileEnd (== '\'') + } diff --git a/src/Codec/GlTF/Root.hs b/src/Codec/GlTF/Root.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GlTF/Root.hs @@ -0,0 +1,43 @@ +module Codec.GlTF.Root where + +import Codec.GlTF.Prelude + +import Codec.GlTF.Asset (Asset) +import Codec.GlTF.Accessor (Accessor) +import Codec.GlTF.Animation (Animation) +import Codec.GlTF.Buffer (Buffer) +import Codec.GlTF.BufferView (BufferView) +import Codec.GlTF.Camera (Camera) +import Codec.GlTF.Image (Image) +import Codec.GlTF.Material (Material) +import Codec.GlTF.Mesh (Mesh) +import Codec.GlTF.Node (Node) +import Codec.GlTF.Sampler (Sampler) +import Codec.GlTF.Scene (Scene) +import Codec.GlTF.Skin (Skin) +import Codec.GlTF.Texture (Texture) + +-- | The root object for a glTF asset. +data GlTF = GlTF + { asset :: Asset + , extensionsUsed :: Maybe (Vector Text) + , extensionsRequired :: Maybe (Vector Text) + , accessors :: Maybe (Vector Accessor) + , animations :: Maybe (Vector Animation) + , buffers :: Maybe (Vector Buffer) + , bufferViews :: Maybe (Vector BufferView) + , cameras :: Maybe (Vector Camera) + , images :: Maybe (Vector Image) + , materials :: Maybe (Vector Material) + , meshes :: Maybe (Vector Mesh) + , nodes :: Maybe (Vector Node) + , samplers :: Maybe (Vector Sampler) + , scenes :: Maybe (Vector Scene) + , skins :: Maybe (Vector Skin) + , textures :: Maybe (Vector Texture) + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON GlTF +instance ToJSON GlTF diff --git a/src/Codec/GlTF/Sampler.hs b/src/Codec/GlTF/Sampler.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GlTF/Sampler.hs @@ -0,0 +1,102 @@ +module Codec.GlTF.Sampler + ( SamplerIx(..) + , Sampler(..) + + , SamplerWrap(..) + , pattern CLAMP_TO_EDGE + , pattern MIRRORED_REPEAT + , pattern REPEAT + + , SamplerMagFilter(..) + , pattern MAG_NEAREST + , pattern MAG_LINEAR + + , SamplerMinFilter(..) + , pattern MIN_NEAREST + , pattern MIN_LINEAR + , pattern MIN_NEAREST_MIPMAP_NEAREST + , pattern MIN_LINEAR_MIPMAP_NEAREST + , pattern MIN_NEAREST_MIPMAP_LINEAR + , pattern MIN_LINEAR_MIPMAP_LINEAR + ) where + +import Codec.GlTF.Prelude + +newtype SamplerIx = SamplerIx { unSamplerIx :: Int } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +-- | The root object for a glTF Sampler. +data Sampler = Sampler + { wrapS :: SamplerWrap + , wrapT :: SamplerWrap + , magFilter :: Maybe SamplerMagFilter + , minFilter :: Maybe SamplerMinFilter + , name :: Maybe Text + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON Sampler where + parseJSON = withObject "Sampler" \o -> do + wrapS <- o .:? "wrapS" .!= REPEAT + wrapT <- o .:? "wrapT" .!= REPEAT + magFilter <- o .:? "magFilter" + minFilter <- o .:? "minFilter" + name <- o .:? "name" + extensions <- o .:? "extensions" + extras <- o .:? "extras" + pure Sampler{..} + +instance ToJSON Sampler where + toJSON = gToJSON + +-- | Wrapping mode. +-- +-- All valid values correspond to WebGL enums. +newtype SamplerWrap = SamplerWrap { unSamplerWrap :: Int } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +pattern CLAMP_TO_EDGE :: SamplerWrap +pattern CLAMP_TO_EDGE = SamplerWrap 33071 + +pattern MIRRORED_REPEAT :: SamplerWrap +pattern MIRRORED_REPEAT = SamplerWrap 33648 + +pattern REPEAT :: SamplerWrap +pattern REPEAT = SamplerWrap 10497 + +-- | Magnification filter. +-- +-- Valid values correspond to WebGL enums. +newtype SamplerMagFilter = SamplerMagFilter { unSamplerMagFilter :: Int } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +pattern MAG_NEAREST :: SamplerMagFilter +pattern MAG_NEAREST = SamplerMagFilter 9728 + +pattern MAG_LINEAR :: SamplerMagFilter +pattern MAG_LINEAR = SamplerMagFilter 9729 + +-- | Minification filter. +-- +-- All valid values correspond to WebGL enums. +newtype SamplerMinFilter = SamplerMinFilter { unSamplerMinFilter :: Int } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +pattern MIN_NEAREST :: SamplerMinFilter +pattern MIN_NEAREST = SamplerMinFilter 9728 + +pattern MIN_LINEAR :: SamplerMinFilter +pattern MIN_LINEAR = SamplerMinFilter 9729 + +pattern MIN_NEAREST_MIPMAP_NEAREST :: SamplerMinFilter +pattern MIN_NEAREST_MIPMAP_NEAREST = SamplerMinFilter 9984 + +pattern MIN_LINEAR_MIPMAP_NEAREST :: SamplerMinFilter +pattern MIN_LINEAR_MIPMAP_NEAREST = SamplerMinFilter 9985 + +pattern MIN_NEAREST_MIPMAP_LINEAR :: SamplerMinFilter +pattern MIN_NEAREST_MIPMAP_LINEAR = SamplerMinFilter 9986 + +pattern MIN_LINEAR_MIPMAP_LINEAR :: SamplerMinFilter +pattern MIN_LINEAR_MIPMAP_LINEAR = SamplerMinFilter 9987 diff --git a/src/Codec/GlTF/Scene.hs b/src/Codec/GlTF/Scene.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GlTF/Scene.hs @@ -0,0 +1,21 @@ +module Codec.GlTF.Scene + ( SceneIx(..) + , Scene(..) + ) where + +import Codec.GlTF.Prelude + +import Codec.GlTF.Node (NodeIx) + +newtype SceneIx = SceneIx { unSceneIx :: Int } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +data Scene = Scene + { nodes :: Maybe (Vector NodeIx) + , name :: Maybe Text + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON Scene +instance ToJSON Scene diff --git a/src/Codec/GlTF/Skin.hs b/src/Codec/GlTF/Skin.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GlTF/Skin.hs @@ -0,0 +1,8 @@ +-- XXX: Misplaced here due to mutual recursion. + +module Codec.GlTF.Skin + ( SkinIx(..) + , Skin(..) + ) where + +import Codec.GlTF.Node (SkinIx(..), Skin(..)) diff --git a/src/Codec/GlTF/Texture.hs b/src/Codec/GlTF/Texture.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GlTF/Texture.hs @@ -0,0 +1,23 @@ +module Codec.GlTF.Texture + ( TextureIx(..) + , Texture(..) + ) where + +import Codec.GlTF.Prelude + +import Codec.GlTF.Image (ImageIx) +import Codec.GlTF.Sampler (SamplerIx) + +newtype TextureIx = TextureIx { unTextureIx :: Int } + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +data Texture = Texture + { sampler :: Maybe SamplerIx + , source :: Maybe ImageIx + , name :: Maybe Text + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance FromJSON Texture +instance ToJSON Texture diff --git a/src/Codec/GlTF/TextureInfo.hs b/src/Codec/GlTF/TextureInfo.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GlTF/TextureInfo.hs @@ -0,0 +1,65 @@ +module Codec.GlTF.TextureInfo + ( TextureInfo(..) + , TextureInfo_ + , Basic(..) + ) where + +import Codec.GlTF.Prelude + +import Data.Foldable (toList) +import Data.Aeson +import qualified Data.HashMap.Strict as HashMap + +-- | Reference to a texture. +data TextureInfo a = TextureInfo + { index :: Int + , texCoord :: Int + -- ^ This integer value is used to construct a string + -- in the format @TEXCOORD_@ which is a reference + -- to a key in @mesh.primitives.attributes@ + -- (e.g. A value of 0 corresponds to @TEXCOORD_0@). + -- + -- Mesh must have corresponding texture coordinate attributes + -- for the material to be applicable to it. + + , subtype :: a + + , extensions :: Maybe Object + , extras :: Maybe Value + } deriving (Eq, Show, Generic) + +instance (FromJSON a) => FromJSON (TextureInfo a) where + parseJSON = withObject "TextureInfo" \o -> do + index <- o .:? "extensions" .!= 0 + texCoord <- o .:? "extras" .!= 0 + subtype <- parseJSON (Object o) + extensions <- o .:? "extensions" + extras <- o .:? "extras" + pure TextureInfo{..} + +instance (ToJSON a) => ToJSON (TextureInfo a) where + toJSON TextureInfo{..} = object $ mconcat + [ [ "index" .= index, "texCoord" .= texCoord] + , case toJSON subtype of + Null -> + [] + Object sub -> + HashMap.toList sub + _ -> + error "assert: subtype of TextureInfo encodes to Object" + , [ "extensions" .= extensions' | extensions' <- toList extensions ] + , [ "extras" .= extras' | extras' <- toList extras ] + ] + +-- | "TextureInfo" without extra fields. +type TextureInfo_ = TextureInfo Basic + +-- | Placeholder for "TextureInfo" objects without extra fields. +data Basic = Basic + deriving (Eq, Ord, Show, Generic) + +instance FromJSON Basic where + parseJSON _value = pure Basic + +instance ToJSON Basic where + toJSON Basic = Null diff --git a/src/Codec/GlTF/URI.hs b/src/Codec/GlTF/URI.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GlTF/URI.hs @@ -0,0 +1,33 @@ +module Codec.GlTF.URI + ( URI(..) + , loadURI + ) where + +import Codec.GlTF.Prelude + +import Data.ByteString (ByteString) +import Data.Text.Encoding (encodeUtf8) +import GHC.Stack (HasCallStack) + +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.Text as Text + +-- | The URI of the buffer or image. +-- +-- Relative paths are relative to the .gltf file. +-- Instead of referencing an external file, the uri can also be a data-uri. +newtype URI = URI Text + deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic) + +loadURI :: HasCallStack => (FilePath -> IO (Either String ByteString)) -> URI -> IO (Either String ByteString) +loadURI fileLoader (URI uri) = + if Text.isPrefixOf "data:" uri then + case Text.breakOn needle uri of + (_prefix, "") -> + error "Malformed data: URI" + (_prefix, found) -> + pure . Base64.decode . encodeUtf8 $ Text.drop (Text.length needle) found + else + fileLoader (Text.unpack uri) + where + needle = ";base64," diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,88 @@ +module Main where + +import Control.Monad (guard) +import Data.Foldable (toList) +import Data.List (isSuffixOf) +import Debug.Trace (traceM) +import Shower (printer) +import System.Directory (listDirectory) +import System.FilePath (()) + +import qualified Data.ByteString as ByteString + +import qualified Codec.GLB as GLB +import qualified Codec.GlTF as GlTF +import qualified Codec.GlTF.Buffer as Buffer +import qualified Codec.GlTF.Image as Image +import qualified Codec.GlTF.Root as Root +import qualified Codec.GlTF.URI as URI + +assetsPath :: FilePath +assetsPath = ".." "assets" + +main :: IO () +main = do + assets <- listDirectory assetsPath + + mapM_ testGltf do + fp <- assets + guard $ ".gltf" `isSuffixOf` fp + pure $ assetsPath fp + + mapM_ testGlb do + fp <- assets + guard $ ".glb" `isSuffixOf` fp + pure $ assetsPath fp + +testGltf :: FilePath -> IO () +testGltf source = + GlTF.fromFile source >>= \case + Left err -> do + traceM err + fail $ "gltf load error in " <> source + Right gltf -> do + printer gltf + testBuffers source gltf + +testGlb :: FilePath -> IO () +testGlb source = + GLB.fromFile source >>= \case + Left (offset, err) -> do + traceM err + fail $ "glb error at " <> show offset + Right glb -> do + printer + ( GLB.header glb + , fmap (\GLB.Chunk{..} -> (chunkLength, chunkType)) (GLB.chunks glb) + ) + case GlTF.fromChunk (head . toList $ GLB.chunks glb) of + Left err -> do + traceM err + fail $ "glb json error inside " <> source + Right gltf -> + printer gltf + +testBuffers :: FilePath -> Root.GlTF -> IO () +testBuffers source gltf = do + case Root.buffers gltf of + Nothing -> + pure () + Just buffers -> + mapM_ (testURI source) $ concatMap (toList . Buffer.uri) buffers + + case Root.images gltf of + Nothing -> + pure () + Just images -> + mapM_ (testURI source) $ concatMap (toList . Image.uri) images + +testURI :: FilePath -> URI.URI -> IO () +testURI _source uri = do + URI.loadURI testLoader uri >>= \case + Left err -> + fail err + Right bs -> + printer (uri, ByteString.length bs) + where + testLoader path = + fmap Right $ ByteString.readFile (assetsPath path)