gltf-codec-0.1.0.1: test/Spec.hs

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)