diff --git a/isobmff-builder.cabal b/isobmff-builder.cabal --- a/isobmff-builder.cabal +++ b/isobmff-builder.cabal @@ -1,5 +1,5 @@ name: isobmff-builder -version: 0.9.0.0 +version: 0.10.0.0 synopsis: A (bytestring-) builder for the ISO-14496-12 base media file format description: Please see README.md homepage: https://github.com/sheyll/isobmff-builder#readme @@ -18,7 +18,8 @@ exposed-modules: Data.ByteString.IsoBaseFileFormat.Boxes , Data.ByteString.IsoBaseFileFormat.Boxes.Box , Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields - , Data.ByteString.IsoBaseFileFormat.Boxes.Brand + , Data.ByteString.IsoBaseFileFormat.Boxes.DataInformation + , Data.ByteString.IsoBaseFileFormat.Boxes.DataReference , Data.ByteString.IsoBaseFileFormat.Boxes.FileType , Data.ByteString.IsoBaseFileFormat.Boxes.FullBox , Data.ByteString.IsoBaseFileFormat.Boxes.Handler @@ -37,6 +38,8 @@ , Data.ByteString.IsoBaseFileFormat.Boxes.TrackHeader , Data.ByteString.IsoBaseFileFormat.Boxes.Versioned , Data.ByteString.IsoBaseFileFormat.Brands.Dash + , Data.ByteString.IsoBaseFileFormat.Brands.Types + , Data.ByteString.IsoBaseFileFormat.Util.TypeLayout build-depends: base >= 4.9 && < 5 , bytestring >= 0.10.8.1 && < 0.11 , type-list >= 0.5.0.0 && < 0.6 @@ -83,7 +86,10 @@ main-is: Spec.hs other-modules: BoxFieldsSpec , BoxSpec + , BrandTypeSpec + , DataReferenceSpec , DashSpec + , TypeLayoutSpec build-depends: base >= 4.9 && < 5 , bytestring >= 0.10.8.1 , hspec diff --git a/spec/BoxFieldsSpec.hs b/spec/BoxFieldsSpec.hs --- a/spec/BoxFieldsSpec.hs +++ b/spec/BoxFieldsSpec.hs @@ -12,24 +12,7 @@ -- qualified Data.Binary.Get as Binary spec :: Spec spec = - do describe "boxSize of Data.Text.Text" $ - it "returns string length + 1 (for the null termination byte)" $ do - boxSize (T.pack "") `shouldBe` 1 - boxSize (T.pack "Hello!") `shouldBe` 7 - describe "boxBuilder of Data.Text.Text" $ do - it "appends the null termination byte" $ - let expected = [72,101,108,108,111,32,119,111,114,108,100,33,0] - actual = BL.unpack $ toLazyByteString $ boxBuilder (T.pack "Hello world!") - in actual `shouldBe` expected - it "appends the null termination byte" $ - let expected = [72,101,108,108,111,32,119,111,114,108,100,33,0] - actual = BL.unpack $ toLazyByteString $ boxBuilder (T.pack "Hello world!") - in actual `shouldBe` expected - it "replaces embeded NULL characters with a space (0x20)" $ - let expected = [72,101,108,108,111,32,119,111,114,108,100,33,0] - actual = BL.unpack $ toLazyByteString $ boxBuilder (T.pack "Hello\0world!") - in actual `shouldBe` expected - describe "mkLanguage" $ + do describe "mkLanguage" $ do it "throws runtime exceptions when the code is too short or too long" $ do evaluate (mkLanguage "") `shouldThrow` anyException evaluate (mkLanguage "a") `shouldThrow` anyException diff --git a/spec/BoxSpec.hs b/spec/BoxSpec.hs --- a/spec/BoxSpec.hs +++ b/spec/BoxSpec.hs @@ -2,15 +2,45 @@ import Test.Hspec import Data.ByteString.IsoBaseFileFormat.Boxes - import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as BL import qualified Data.Binary.Get as Binary +import qualified Data.Text as T spec :: Spec spec = do describe "IsBoxContent instances" $ - do describe "()" $ + do describe "IsBoxContent Data.Text.Text" $ + do describe "boxSize" $ + it "returns string length + 1 (for the null termination byte)" $ + do boxSize (T.pack "") `shouldBe` 1 + boxSize (T.pack "Hello!") `shouldBe` 7 + describe "boxBuilder of Data.Text.Text" $ + do it "appends the null termination byte" $ + let expected = + [72,101,108,108,111,32,119,111,114,108,100,33,0] + actual = + BL.unpack $ + toLazyByteString $ + boxBuilder (T.pack "Hello world!") + in actual `shouldBe` expected + it "appends the null termination byte" $ + let expected = + [72,101,108,108,111,32,119,111,114,108,100,33,0] + actual = + BL.unpack $ + toLazyByteString $ + boxBuilder (T.pack "Hello world!") + in actual `shouldBe` expected + it "replaces embeded NULL characters with a space (0x20)" $ + let expected = + [72,101,108,108,111,32,119,111,114,108,100,33,0] + actual = + BL.unpack $ + toLazyByteString $ + boxBuilder (T.pack "Hello\0world!") + in actual `shouldBe` expected + describe "()" $ do describe "boxSize" $ it "returns 0" $ boxSize () `shouldBe` 0 describe "boxBuilder" $ it "emits no data" $ @@ -34,26 +64,23 @@ reportedSize = boxSize b in writtenSize `shouldBe` reportedSize -data TestBrand - -instance IsBrand TestBrand where - type BoxLayout TestBrand = - '[ 'OnceMandatory TestParentBox1 '[ 'SomeOptional TestBox1 '[]] ] - data TestBox1 -instance IsBoxType TestBox1 where - toBoxType _ _ = StdType "tst1" +instance IsBox TestBox1 where + type BoxContent TestBox1 = () -testBox1 :: Box TestBrand TestBox1 -testBox1 = closedBox () +type instance BoxTypeSymbol TestBox1 = "tst1" +testBox1 :: Box TestBox1 +testBox1 = Box () + data TestParentBox1 -instance IsBoxType TestParentBox1 where - toBoxType _ _ = StdType "par1" +instance IsBox TestParentBox1 where + type BoxContent TestParentBox1 = () +type instance BoxTypeSymbol TestParentBox1 = "par1" + testParentBox1 - :: ValidContainerBox TestBrand TestParentBox1 ts - => Boxes TestBrand ts -> Box TestBrand TestParentBox1 -testParentBox1 = containerBox + :: Boxes ts -> Box (ContainerBox TestParentBox1 ts) +testParentBox1 = containerBox () diff --git a/spec/BrandTypeSpec.hs b/spec/BrandTypeSpec.hs new file mode 100644 --- /dev/null +++ b/spec/BrandTypeSpec.hs @@ -0,0 +1,70 @@ +module BrandTypeSpec + (spec) + where + +import Test.Hspec +import Data.ByteString.IsoBaseFileFormat.Boxes +import Data.ByteString.IsoBaseFileFormat.Brands.Types +import Data.ByteString.Lazy (unpack) + +spec :: Spec +spec = + describe "mediaBuilder" $ + do describe "Empty BoxLayout" $ + it "accepts valid box content types" $ + let test = + mediaBuilder (Proxy :: Proxy TestBrandEmpty) + NoBoxes + in printBuilder test + describe "Single Box BoxLayout" $ + it "accepts valid box content types" $ + let test = + mediaBuilder (Proxy :: Proxy TestBrandSingle) + (singletonBox testBox1) + in printBuilder test + describe "Multiple nested Boxes BoxLayout" $ + it "accepts valid box content types" $ + let test = + mediaBuilder (Proxy :: Proxy TestBrandNested) + (singletonBox (testParentBox1 $: testBox1)) + in printBuilder test + +printBuilder :: Builder -> IO () +printBuilder b = + putStrLn $ unlines $ (" "++) <$> lines (show (unpack (toLazyByteString b))) + +data TestBox1 + +instance IsBox TestBox1 where + type BoxContent TestBox1 = () + +type instance BoxTypeSymbol TestBox1 = "tst1" + +testBox1 :: Box TestBox1 +testBox1 = Box () + +data TestParentBox1 + +instance IsBox TestParentBox1 where + type BoxContent TestParentBox1 = () + +type instance BoxTypeSymbol TestParentBox1 = "par1" + +testParentBox1 + :: Boxes ts -> Box (ContainerBox TestParentBox1 ts) +testParentBox1 = containerBox () + +data TestBrandEmpty + +instance IsBrand TestBrandEmpty where + type BoxLayout TestBrandEmpty = Boxes '[] + +data TestBrandSingle + +instance IsBrand TestBrandSingle where + type BoxLayout TestBrandSingle = Boxes '[OM_ TestBox1] + +data TestBrandNested + +instance IsBrand TestBrandNested where + type BoxLayout TestBrandNested = Boxes '[OM TestParentBox1 '[OM_ TestBox1]] diff --git a/spec/DashSpec.hs b/spec/DashSpec.hs --- a/spec/DashSpec.hs +++ b/spec/DashSpec.hs @@ -8,7 +8,7 @@ spec :: Spec spec = - do describe "minimalIsobmff version 0" $ + do describe "SingleAudioTrackInit version 0" $ do it "renders some output at all" $ do createionTime <- mp4CurrentTime let ct :: Word32 @@ -21,272 +21,65 @@ cts = fromIntegral <$> [ct3,ct2,ct1,ct0] let args = exampleSingleTrackInit createionTime doc = mkSingleTrackInit args - rendered = BL.unpack $ packMediaFile doc + rendered = BL.unpack $ toLazyByteString $ doc expected = - [0 - ,0 - ,0 - ,32 - ,102 - ,116 - ,121 - ,112 - ,105 - ,115 - ,111 - ,53 - ,0 - ,0 - ,0 - ,0 - ,105 - ,115 - ,111 - ,109 - ,105 - ,115 - ,111 - ,53 - ,100 - ,97 - ,115 - ,104 - ,109 - ,112 - ,52 - ,50 - ,0 - ,0 - ,1 - ,73 -- Here - ,109 - ,111 - ,111 - ,118 - ,0 - ,0 - ,0 - ,108 - ,109 - ,118 - ,104 - ,100 - ,0 - ,0 - ,0 - ,0] ++ - cts ++ - [0 - ,0 - ,0 - ,0 - ,0 - ,1 - ,95 - ,144 - ,0 - ,1 - ,95 - ,144 - ,0 - ,1 - ,0 - ,0 - ,1 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,1 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,1 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,64 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,255 - ,255 - ,255 - ,255 - ,0 - ,0 - ,0 - ,213 -- Here - ,116 - ,114 - ,97 - ,107 - ,0 - ,0 - ,0 - ,92 - ,116 - ,107 - ,104 - ,100 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,1 - ,0 - ,0 - ,0 - ,0 - ,0 - ,1 - ,95 - ,144 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,1 - ,0 - ,0 - ,0 - ,0 - ,1 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,1 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,64 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0 - ,0,0,0,113 -- HERE + [ + -- ftyp box + 0,0,0,28,102,116,121,112,100,97,115,104,0,0,0,0 + ,105,115,111,109,105,115,111,53,109,112,52,50,0,0 + -- moov box + ,1 ,105 ,109 ,111 ,111 ,118 + -- mvhd box + ,0 ,0 ,0 ,108 ,109 ,118 ,104 ,100 ,0 ,0 ,0 ,0] + ++ cts ++ [0 ,0 ,0 ,0 ,0 + ,1 ,95 ,144 ,0 ,1 ,95 ,144 ,0 ,1 ,0 ,0 ,1 ,0 ,0 ,0 + ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,1 ,0 ,0 ,0 ,0 ,0 ,0 + ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,1 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 + ,0 ,0 ,0 ,0 ,0 ,0 ,64 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 + ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 + ,255 ,255 ,255 ,255 + -- trak box + ,0 ,0 ,0 ,245 + ,116 ,114 ,97 ,107 + -- tkhd box + ,0 ,0 ,0 ,92 + ,116 ,107 ,104 ,100 + ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 + ,0 ,1 ,0 ,0 ,0 ,0 ,0 ,1 ,95 ,144 ,0 ,0 + ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,1 ,0 ,0 ,0 + ,0 ,1 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 + ,0 ,1 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 + ,0 ,64 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 + -- mdia box + ,0,0,0,145 ,109,100,105,97 ,0,0,0,32,109,100,104,100,0,0,0,0 ,0,0,0,0,0,0,0,0,0,1,95,144,0,0,0,0,16,181,0,0 - ,0,0,0,45 -- HERE + -- hdlr box + ,0,0,0,45 ,104,100,108,114 ,0,0,0,0,0,0,0,0,115,111,117,110,0,0,0,0,0,0,0,0,0,0,0,0 ,72,101,108,108,111,32,119,111,114,108,100,33,0 - ,0,0,0,28 -- HERE + ,0,0,0,60 ,109,105,110,102 - ,0,0,0,20 -- HERE - ,115,109,104,100,0,0,0,0,0,0,0,0,0,0,0,0] + ,0,0,0,16 + ,115,109,104,100,0,0,0,0,0,0,0,0 + ,0,0,0,36 + ,100,105,110,102 + ,0,0,0,28 + ,100,114,101,102 + ,0,0,0,0,0,0,0,1 + ,0,0,0,12 + ,117,114,110,32 + ,0,0,0,1] -- BL.writeFile "/tmp/xxx.mp4" (BL.pack rendered) rendered `shouldBe` expected -exampleSingleTrackInit :: U32 "creation_time" -> SingleTrackInit +exampleSingleTrackInit :: U32 "creation_time" -> SingleAudioTrackInit exampleSingleTrackInit creationTime = - SingleTrackInit (MovieHeader $ + SingleAudioTrackInit + (MovieHeader $ V0 (creationTime :+ 0 :+ Default :+ durationFromSeconds Default 1) :+ def) (TrackHeader $ diff --git a/spec/DataReferenceSpec.hs b/spec/DataReferenceSpec.hs new file mode 100644 --- /dev/null +++ b/spec/DataReferenceSpec.hs @@ -0,0 +1,25 @@ +module DataReferenceSpec (spec) where + +import Test.Hspec +import Data.ByteString.IsoBaseFileFormat.Boxes + +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Binary.Get as Binary +import qualified Data.Text as T + +spec :: Spec +spec = return () +-- describe "IsBoxContent" $ do +-- describe "LocalMediaEntry" $ do +-- describe "boxSize" $ do +-- it "returns 0" $ +-- let actual = boxSize (localMediaDataReference :: DRef) +-- -- dref: size+fourcc+fullbox+entries -> 4 * 4bytes +-- expected = 4 + 4 + 4 + 4 + (4 + 4 + boxSize ("xxxx" :+ FullBox Default 0 () :: DEntryLocal)) +-- in actual `shouldBe` expected +-- +-- -- type DRef = Box (Dash 0) DataReference +-- type DEntryLocal = FourCc :+ FullBox 0 () +-- type DEntryUrl = FourCc :+ FullBox 0 (T.Text) +-- type DEntryUrn = FourCc :+ FullBox 0 (T.Text :+ T.Text) diff --git a/spec/TypeLayoutSpec.hs b/spec/TypeLayoutSpec.hs new file mode 100644 --- /dev/null +++ b/spec/TypeLayoutSpec.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +module TypeLayoutSpec (spec) where + +import Test.Hspec +import GHC.TypeLits () +import Data.ByteString.IsoBaseFileFormat.Util.TypeLayout +import Data.ByteString.IsoBaseFileFormat.Boxes.Box + +spec :: Spec +spec = + describe "IsRuleConform" $ do + describe "TopLevel" $ do + it "validates TopLevel Boxes" $ test1 `shouldBe` () + describe "ContainerBoxes" $ do + describe "OnceOptional" $ do + it "validates empty containters" $ test2a `shouldBe` () + it "validates a singleton container" $ test2b `shouldBe` () + describe "SomeOptional" $ do + it "validates empty containters" $ test3a `shouldBe` () + it "validates a singleton container" $ test3b `shouldBe` () + it "validates a multi-element container" $ test3c `shouldBe` () + describe "(implied) mandatory" $ do + it "validates a singleton container" $ test4 `shouldBe` () + describe "SomeMandatory" $ do + it "validates a singleton container" $ test5a `shouldBe` () + it "validates a multi-element container" $ test5b `shouldBe` () + it "validates a Mix of SomeMandatory, OnceOptional, SomeOptional" $ do + test6a `shouldBe` () + test6b `shouldBe` () + test6c `shouldBe` () + test6d `shouldBe` () + it "validates deeply nested container" $ do + test7a `shouldBe` () + test7b `shouldBe` () + test7c `shouldBe` () + +---- +data Foo +type instance ToSymbol Foo = "foo " +data Fov +type instance ToSymbol Fov = "fov " +data Bar +type instance ToSymbol Bar = "bar " +data Baz +type instance ToSymbol Baz = "baz " +---- +type TestRule1 = TopLevel (MatchSymbol "foo ") +type TestType1 = Foo +test1 :: (IsRuleConform TestType1 TestRule1 ~ 'True) => () +test1 = () +---- +type TestRule2 = TopLevel (ContainerBox Foo '[OnceOptionalX (MatchSymbol "bar ")]) +type TestType2a = Box (ContainerBox Foo '[]) +test2a :: (IsRuleConform TestType2a TestRule2 ~ 'True) => () +test2a = () +-- +type TestType2b = Box (ContainerBox Foo '[Bar]) +test2b :: (IsRuleConform TestType2b TestRule2 ~ 'True) => () +test2b = () +---- +type TestRule3 = TopLevel (ContainerBox Foo '[SomeOptionalX (MatchSymbol "bar ")]) +type TestType3a = Box (ContainerBox Foo '[]) +test3a :: (IsRuleConform TestType3a TestRule3 ~ 'True) => () +test3a = () +-- +type TestType3b = Box (ContainerBox Foo '[Bar]) +test3b :: (IsRuleConform TestType3b TestRule3 ~ 'True) => () +test3b = () +-- +type TestType3c = Box (ContainerBox Foo '[Bar,Bar]) +test3c :: (IsRuleConform TestType3c TestRule3 ~ 'True) => () +test3c = () +---- +type TestRule4 = TopLevel (ContainerBox Foo '[MatchSymbol "bar "]) +type TestType4 = Box (ContainerBox Foo '[Bar]) +test4 :: (IsRuleConform TestType4 TestRule4 ~ 'True) => () +test4 = () +---- +type TestRule5 = TopLevel (ContainerBox Foo '[SomeMandatoryX (MatchSymbol "bar ")]) +type TestType5a = Box (ContainerBox Foo '[Bar]) +test5a :: (IsRuleConform TestType5a TestRule5 ~ 'True) => () +test5a = () +type TestType5b = Box (ContainerBox Foo '[Bar, Bar]) +test5b :: (IsRuleConform TestType5b TestRule5 ~ 'True) => () +test5b = () +---- +type TestRule6 = + (ContainerBox Foo + '[ OnceOptionalX (MatchSymbol "baz ") + , SomeMandatoryX (MatchSymbol "bar ") + , SomeOptionalX (MatchSymbol "fov ") + , MatchSymbol "foo "]) +type TestType6a = + Box (ContainerBox Foo '[Baz,Bar,Bar,Bar,Fov,Fov,Foo]) +test6a :: (IsRuleConform TestType6a TestRule6 ~ 'True) => () +test6a = () +type TestType6b = + Box (ContainerBox Foo '[Bar,Bar,Bar,Fov,Fov,Foo]) +test6b :: (IsRuleConform TestType6b TestRule6 ~ 'True) => () +test6b = () +type TestType6c = + Box (ContainerBox Foo '[Bar,Fov,Fov,Foo]) +test6c :: (IsRuleConform TestType6c TestRule6 ~ 'True) => () +test6c = () +type TestType6d = Box (ContainerBox Foo '[Bar,Foo]) +test6d :: (IsRuleConform TestType6d TestRule6 ~ 'True) => () +test6d = () +---- +type TestRule7 = + TopLevel (ContainerBox Foo + '[ SomeOptionalX (ContainerBox Fov + '[ OnceOptionalX (ContainerBox Baz + '[MatchSymbol "foo "]) + , SomeMandatoryX (MatchSymbol "bar ") + ])]) +type TestType7a = Box (ContainerBox Foo '[ ]) +test7a :: (IsRuleConform TestType7a TestRule7 ~ 'True) => () +test7a = () +type TestType7b = Box (ContainerBox Foo + '[ Box (ContainerBox Fov + '[Box (ContainerBox Baz + '[Foo]) + , Bar])]) +test7b :: (IsRuleConform TestType7b TestRule7 ~ 'True) => () +test7b = () +type TestType7c = Box (ContainerBox Foo + '[ Box (ContainerBox Fov + '[ Box (ContainerBox Baz + '[Foo]) + , Bar + , Bar + , Bar + ]) + , Box (ContainerBox Fov + '[ Box (ContainerBox Baz + '[Foo]) + , Bar + , Bar + , Bar + ]) + ]) +test7c :: (IsRuleConform TestType7c TestRule7 ~ 'True) => () +test7c = () diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes.hs @@ -1,10 +1,12 @@ -- | This module re-exports all modules needed to build /ISOBMFF/ documents. module Data.ByteString.IsoBaseFileFormat.Boxes - (module Data.ByteString.IsoBaseFileFormat.Boxes, module X) + ( module X) where import Data.ByteString.IsoBaseFileFormat.Boxes.Box as X import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields as X +import Data.ByteString.IsoBaseFileFormat.Boxes.DataInformation as X +import Data.ByteString.IsoBaseFileFormat.Boxes.DataReference as X import Data.ByteString.IsoBaseFileFormat.Boxes.FileType as X import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox as X import Data.ByteString.IsoBaseFileFormat.Boxes.Handler as X @@ -22,7 +24,6 @@ import Data.ByteString.IsoBaseFileFormat.Boxes.Track as X import Data.ByteString.IsoBaseFileFormat.Boxes.TrackHeader as X import Data.ByteString.IsoBaseFileFormat.Boxes.Versioned as X -import qualified Data.ByteString.Lazy as BL import Data.Int as X import Data.Kind as X (Type, Constraint) @@ -31,13 +32,3 @@ import Data.Type.Equality as X import Text.Printf as X import Data.Default as X - --- * MediaFiles - --- | The toplevel container for all boxes of a media file. -data MediaFile brand where - MediaFile :: (ValidTopLevel brand ts) => Boxes brand ts -> MediaFile brand - --- | Generate a lazy 'ByteString' with the contents of a 'MediaFile' -packMediaFile :: MediaFile brand -> BL.ByteString -packMediaFile (MediaFile bs) = toLazyByteString (boxBuilder bs) diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Box.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Box.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Box.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Box.hs @@ -12,7 +12,7 @@ (module Data.ByteString.IsoBaseFileFormat.Boxes.Box, module X) where -import Data.ByteString.IsoBaseFileFormat.Boxes.Brand as X +import Data.ByteString.IsoBaseFileFormat.Util.TypeLayout as X import Data.Bits as X import Data.ByteString.Builder as X import Data.Monoid as X @@ -21,6 +21,10 @@ import Data.Kind import GHC.TypeLits as X import Data.String +import Data.Default +import Data.Singletons.Prelude.List (Length) +import Data.Type.Equality +import Data.Type.Bool import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Singletons.Prelude.List ((:++)) @@ -28,11 +32,18 @@ -- * Box Type Classes -- | Base class for all (abstract/phantom/normal-) types that represent boxes -class (IsBoxContent (BoxContent t)) => IsBoxType t where +class (KnownSymbol (BoxTypeSymbol t), IsBoxContent (BoxContent t)) => IsBox t where type BoxContent t - type BoxContent t = () - toBoxType :: proxy t -> BoxContent t -> BoxType + type BoxContent t = t + toBoxType :: proxy t -> BoxType + toBoxType _ = parseBoxType (Proxy :: Proxy (BoxTypeSymbol t)) +-- | A type family used by the type-level consistency checks. It is required +-- that an instance of this type family exists for every 'IsBox' instance. +-- This family could not be associative since it is used by type families that +-- cannot have type class constraints. +type family BoxTypeSymbol t :: Symbol + -- | Types that go into a box. A box content is a piece of data that can be -- reused in different instances of 'IsBox'. It has no 'BoxType' and hence -- defines no box. @@ -41,36 +52,55 @@ boxBuilder :: a -> Builder -- * Data types + + -- | A type that wraps the contents of a box and the box type. -data Box brand b where +data Box b where Box :: - (IsBoxType b, IsBrandConform brand ('Just b) ts) => - BoxContent b -> Boxes brand ts -> Box brand b + (IsBox b) => + BoxContent b -> Box b -instance IsBoxContent (Box brand cnt) where - boxBuilder b@(Box cnt nested) = sB <> tB <> sExtB <> tExtB <> cntB <> nestedB +instance IsBox b => IsBox (Box b) where + type BoxContent (Box b) = BoxContent b + toBoxType _ = toBoxType (Proxy :: Proxy b) + +type instance BoxTypeSymbol (Box b) = BoxTypeSymbol b + +instance IsBoxContent (Box cnt) where + boxBuilder b@(Box cnt) = sB <> tB <> sExtB <> tExtB <> cntB where s = boxSize b - t = toBoxType b cnt + t = toBoxType b sB = boxBuilder s sExtB = boxBuilder (BoxSizeExtension s) tB = boxBuilder t tExtB = boxBuilder (BoxTypeExtension t) cntB = boxBuilder cnt - nestedB = boxBuilder nested - boxSize b@(Box cnt nested) = sPayload + boxSize (BoxSizeExtension sPayload) + boxSize b@(Box cnt) = sPayload + boxSize (BoxSizeExtension sPayload) where sPayload = boxSize (BoxSize undefined) + boxSize t + boxSize cnt + - boxSize (BoxTypeExtension t) + - boxSize nested - t = toBoxType b cnt + boxSize (BoxTypeExtension t) + t = toBoxType b +-- | Compose 'BoxContent' and 'Boxes' under the Constraint that they are +-- composable. +data ContainerBox b (bs :: [Type]) where + ContainerBox :: IsBox b => BoxContent b -> Boxes bs -> ContainerBox b bs + +instance (IsBox b) => IsBox (ContainerBox b bs) + +type instance BoxTypeSymbol (ContainerBox b bs) = BoxTypeSymbol b + +instance IsBoxContent (ContainerBox b bs) where + boxSize (ContainerBox c bs) = boxSize (c :+ bs) + boxBuilder (ContainerBox c bs) = boxBuilder (c :+ bs) + -- | A heterogenous collection of boxes. -data Boxes brand (boxTypes :: [Type]) where - NoBoxes :: Boxes brand '[] - (:.) :: Box brand l -> Boxes brand r -> Boxes brand (l ': r) - -- | Create a 'Boxes' collection from two 'Box'es - (:|) :: Box brand l -> Box brand r -> Boxes brand '[l, r] - (:<>) :: Boxes brand l -> Boxes brand r -> Boxes brand (l :++ r) +data Boxes (boxTypes :: [Type]) where + NoBoxes :: Boxes '[] + (:.) :: Box l -> Boxes r -> Boxes (Box l ': r) + -- | Create a 'Boxes' collection from two 'Box'es + (:<>) :: Boxes l -> Boxes r -> Boxes (l :++ r) + (:|) :: Box l -> Box r -> Boxes '[Box l, Box r] infixr 1 :<> infixr 2 :. @@ -78,15 +108,19 @@ infixr 3 $: -- | Apply a function to a 'Boxes' collection containing only a single 'Box'. -($:) :: (Boxes brand '[l] -> r) -> Box brand l -> r +($:) :: (Boxes '[Box l] -> r) -> Box l -> r ($:) f = f . singletonBox -- | Create a 'Boxes' collection with a single 'Box'. -singletonBox :: Box brand l -> Boxes brand '[l] +singletonBox :: Box l -> Boxes '[Box l] singletonBox b = b :. NoBoxes +-- | Get the elements in a type level array +typeListLength :: forall a proxy (ts :: [k]) . (KnownNat (Length ts), Num a) + => proxy ts -> a +typeListLength _ = fromIntegral (natVal (Proxy :: Proxy (Length ts))) -instance IsBoxContent (Boxes brand bs) where +instance IsBoxContent (Boxes bs) where boxSize NoBoxes = 0 boxSize (l :. r) = boxSize l + boxSize r boxSize (l :| r) = boxSize l + boxSize r @@ -96,15 +130,10 @@ boxBuilder (l :| r) = boxBuilder l <> boxBuilder r boxBuilder (l :<> r) = boxBuilder l <> boxBuilder r --- | A box that contains no nested boxes. -closedBox :: (IsBoxType t, IsBrandConform brand ('Just t) '[]) - => BoxContent t -> Box brand t -closedBox c = Box c NoBoxes - -- | A box that contains no fields, but nested boxes. -containerBox :: (IsBoxType t,IsBrandConform brand ('Just t) ts,BoxContent t ~ ()) - => Boxes brand ts -> Box brand t -containerBox = Box () +containerBox :: (IsBox t) + => BoxContent t -> Boxes ts -> Box (ContainerBox t ts) +containerBox c bs = Box (ContainerBox c bs) -- * Box Size and Type -- | The size of the box. If the size is limited to a (fixed) value, it can be @@ -170,6 +199,12 @@ CustomBoxType String deriving (Show,Eq) +-- | Create a box type from a 'Symbol'. Parse the symbol value, if it's a four +-- charachter code, then return that as 'StdType' otherwise parse a UUID (TODO) +-- and return a 'CustomBoxType'. +parseBoxType :: KnownSymbol t => proxy t -> BoxType +parseBoxType px = StdType (fromString (symbolVal px)) + -- | A type containin a printable four letter character code. newtype FourCc = FourCc (Char,Char,Char,Char) @@ -230,3 +265,57 @@ boxSize = (1+) . fromIntegral . T.length boxBuilder txt = boxBuilder (T.encodeUtf8 txtNoNulls) <> word8 0 where txtNoNulls = T.map (\c -> if c == '\0' then ' ' else c) txt + +-- | This instance writes zero bytes for 'Nothing' and delegates on 'Just'. +instance IsBoxContent a => IsBoxContent (Maybe a) where + boxSize = maybe 0 boxSize + boxBuilder = maybe mempty boxBuilder + +-- * Box concatenation + +-- | Box content composition +data a :+ b = a :+ b + +infixr 3 :+ + +instance (IsBoxContent p,IsBoxContent c) => IsBoxContent (p :+ c) where + boxSize (p :+ c) = boxSize p + boxSize c + boxBuilder (p :+ c) = boxBuilder p <> boxBuilder c + +instance (Default a, Default b) => Default (a :+ b) where + def = def :+ def + +-- * Type Layout Rule Matchers + +-- | Mandatory, container box, exactly one +type OM b bs = ContainerBox b bs +-- | Optional, container box, zero or one +type OO b bs = OnceOptionalX (ContainerBox b bs) +-- | Mandatory, container box, one or more +type SM b bs = SomeMandatoryX (ContainerBox b bs) +-- | Optional, container box, zero or more +type SO b bs = SomeOptionalX (ContainerBox b bs) + +-- | Mandatory, exactly one, no children +type OM_ b = Box b +-- | Optional, zero or one, no children +type OO_ b = OnceOptionalX (Box b) +-- | Mandatory, one or more, no children +type SM_ b = SomeMandatoryX (Box b) +-- | Optional, zero or more, no children +type SO_ b = SomeOptionalX (Box b) + +---- +type instance IsRuleConform (Box b) (Box r) = BoxTypeSymbol b == BoxTypeSymbol r +---- +type instance IsRuleConform (Boxes bs) (Boxes rs) = IsRuleConform bs rs -- TODO +---- +type instance IsRuleConform (Box b) (ContainerBox b' rules) + = IsContainerBox b + && IsRuleConform (Box b) (Box b') + && IsRuleConform (ChildBoxes b) (Boxes rules) +type family IsContainerBox t :: Bool where + IsContainerBox (ContainerBox a as) = 'True + IsContainerBox b = 'False +type family ChildBoxes c where + ChildBoxes (ContainerBox a as) = Boxes as diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/BoxFields.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/BoxFields.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/BoxFields.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/BoxFields.hs @@ -4,6 +4,7 @@ where import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.ByteString.IsoBaseFileFormat.Boxes.Versioned import Data.Default import Data.Int import Data.Maybe @@ -246,16 +247,9 @@ instance KnownSymbol str => FromTypeLit T.Text (str :: Symbol) where fromTypeLit = T.pack . symbolVal --- * Box concatenation - --- | Box content composition -data a :+ b = a :+ b - -infixr 3 :+ - -instance (IsBoxContent p,IsBoxContent c) => IsBoxContent (p :+ c) where - boxSize (p :+ c) = boxSize p + boxSize c - boxBuilder (p :+ c) = boxBuilder p <> boxBuilder c +-- * Versioned support -instance (Default a, Default b) => Default (a :+ b) where - def = def :+ def +-- | A utility for 'Versioned' to apply a type constructor to either a +-- @('Scalar' Word32)@ or a @('Scalar' Word64)@ depending on the type level +-- version. This uses 'SelectByVersion'. +type U32U64 c = SelectByVersion c (Scalar Word32) (Scalar Word64) diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Brand.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Brand.hs deleted file mode 100644 --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Brand.hs +++ /dev/null @@ -1,217 +0,0 @@ --- | Brand/Box-validation -{-# LANGUAGE UndecidableInstances #-} -module Data.ByteString.IsoBaseFileFormat.Boxes.Brand - (IsBrand(..), ValidBox, ValidContainerBox, ValidTopLevel, - IsBrandConform, BoxTree(..), BoxForrest, - OM,OM_,OO,OO_,SM,SM_,SO,SO_) - where - -import Data.Kind -import Data.Type.Bool -import GHC.TypeLits --- import GHC.Exts -import Data.Singletons (Apply, type (~>)) -import Data.Singletons.Prelude.List as S (Map, (:++)) -import Data.Type.List (Find) - --- | A class that describes (on the type level) how a box can be nested into --- other boxes (see 'Boxes). -class KnownNat (GetVersion brand) => IsBrand brand where - type BoxLayout brand :: BoxForrest - type BoxLayout brand = '[] - type GetVersion brand :: Nat - type GetVersion brand = 0 - --- | Mandatory, container box, exactly one -type OM b bs = 'OnceMandatory b bs --- | Optional, container box, zero or one -type OO b bs = 'OnceOptional b bs --- | Mandatory, container box, one or more -type SM b bs = 'SomeMandatory b bs --- | Optional, container box, zero or more -type SO b bs = 'SomeOptional b bs - --- | Mandatory, exactly one, no children -type OM_ b = 'OnceMandatory b '[] --- | Optional, zero or one, no children -type OO_ b = 'OnceOptional b '[] --- | Mandatory, one or more, no children -type SM_ b = 'SomeMandatory b '[] --- | Optional, zero or more, no children -type SO_ b = 'SomeOptional b '[] - --- | Boxes that valid according to the box structure defined in a 'IsBrand' --- instance, i.e. where 'IsBrandConform' holds. -type family - IsBrandConform (b :: Type) (parent :: Maybe Type) (ts :: [Type]) :: Constraint where - IsBrandConform b 'Nothing ts = - IsBrandConformImpl b (TopLevel b) ts (BoxLayout b) - IsBrandConform b ('Just parent) ts = - IsBrandConformImpl b parent ts (LookUpSubtrees parent (BoxLayout b)) - --- | Convenience wrapper around @(IsBrandConform b ('Just t) '[])@ -type ValidBox b t = IsBrandConform b ('Just t) '[] - --- | Convenience wrapper around @(IsBrandConform b ('Just t) ts)@ -type ValidContainerBox b t ts = IsBrandConform b ('Just t) ts - --- | Convenience wrapper around @(IsBrandConform b 'Nothing ts)@ -type ValidTopLevel b ts = IsBrandConform b 'Nothing ts - - --- | Define the cardinality and valid child boxes of a box. -data BoxTree - = OnceOptional Type - BoxForrest - | OnceMandatory Type - BoxForrest - | SomeOptional Type - BoxForrest - | SomeMandatory Type - BoxForrest - --- | A list of 'BoxTree's -type BoxForrest = [BoxTree] - --- * Implementation - --- | A type for marking top-level boxes in TypeError messages, in the --- 'IsBrandConformImpl' constraint. -data TopLevel :: t -> Type - - -type family - LookUpSubtrees t (trees :: BoxForrest) :: BoxForrest where - LookUpSubtrees t '[] = '[] - LookUpSubtrees t ('OnceOptional t sub ': rest) = sub - LookUpSubtrees t ('OnceOptional u sub ': rest) = LookUpSubtrees t (sub :++ rest) - LookUpSubtrees t ('OnceMandatory t sub ': rest) = sub - LookUpSubtrees t ('OnceMandatory u sub ': rest) = LookUpSubtrees t (sub :++ rest) - LookUpSubtrees t ('SomeOptional t sub ': rest) = sub - LookUpSubtrees t ('SomeOptional u sub ': rest) = LookUpSubtrees t (sub :++ rest) - LookUpSubtrees t ('SomeMandatory t sub ': rest) = sub - LookUpSubtrees t ('SomeMandatory u sub ': rest) = LookUpSubtrees t (sub :++ rest) - --- | A constraint that is solved if all 'Box'es layed out in accordance with the --- 'BoxLayout' if an 'IsBrand' instance. -type IsBrandConformImpl b (info :: Type) (ts :: [Type]) (boxForrest :: BoxForrest) = - ( IsBrand b - , ReportIt '[AllRequiredBoxes - boxForrest - ts] - , ReportIt '[OnlyValidBoxes info - boxForrest - ts] - , ReportIt (Map (RuleAppliesFun info ts) - boxForrest)) - -type family - ReportIt (es :: [Maybe ErrorMessage]) :: Constraint where - ReportIt '[] = () - ReportIt ('Nothing ': rest) = ReportIt rest - ReportIt ('Just e ': rest) = TypeError e - -type family - AllRequiredBoxes (f :: BoxForrest) (ts :: [t]) :: Maybe ErrorMessage where - AllRequiredBoxes '[] children = 'Nothing - - AllRequiredBoxes ('OnceMandatory c sub ': rules) '[] = - 'Just ('Text "OnceMandatory box '" - ':<>: 'ShowType c ':<>: 'Text "' missing, or out of order.") - AllRequiredBoxes ('SomeMandatory c sub ': rules) '[] = - 'Just ('Text "SomeMandatory box '" - ':<>: 'ShowType c ':<>: 'Text "' missing, or out of order.") - - AllRequiredBoxes ('OnceMandatory c sub ': rules) (c ': children) = - AllRequiredBoxes rules children - AllRequiredBoxes ('SomeMandatory c sub ': rules) (c ': children) = - AllRequiredBoxes rules (RemoveNext c children) - - AllRequiredBoxes ('OnceMandatory c sub ': rules) children = - AllRequiredBoxes rules children - AllRequiredBoxes ('SomeMandatory c sub ': rules) children = - AllRequiredBoxes rules children - - AllRequiredBoxes ('OnceOptional c sub ': rules) (c ': children) = - AllRequiredBoxes rules children - AllRequiredBoxes ('OnceOptional c sub ': rules) children = - AllRequiredBoxes rules children - AllRequiredBoxes ('SomeOptional c sub ': rules) children = - AllRequiredBoxes rules (RemoveNext c children) - -type family - OnlyValidBoxes (r :: t) (f :: BoxForrest) (ts :: [t]) :: Maybe ErrorMessage where - OnlyValidBoxes r rules (c ': children) = - If (Find c (ExtractBoxes rules)) - (OnlyValidBoxes r rules children) - ('Just ('Text "Invalid box '" ':<>: 'ShowType c - ':<>: 'Text "' in box '" ':<>: 'ShowType r ':<>: 'Text "'")) - OnlyValidBoxes r rules '[] = 'Nothing - -type family - ExtractBoxes (f :: BoxForrest) :: [t] where - ExtractBoxes '[] = '[] - ExtractBoxes ('OnceMandatory c sub ': rules) = - c ': ExtractBoxes rules - ExtractBoxes ('SomeMandatory c sub ': rules) = - c ': ExtractBoxes rules - ExtractBoxes ('OnceOptional c sub ': rules) = - c ': ExtractBoxes rules - ExtractBoxes ('SomeOptional c sub ': rules) = - c ': ExtractBoxes rules - -type family - RemoveNext (t :: k) (ts :: [k]) :: [k] where - RemoveNext t (t ': ts) = RemoveNext t ts - RemoveNext t ts = ts - -data RuleAppliesFun :: t -> [t] -> BoxTree ~> Maybe ErrorMessage - -type instance Apply (RuleAppliesFun parent childBoxes) rules = - RuleApplies parent childBoxes rules - -type family - RuleApplies (parent :: t) (childBoxes :: [t]) (rules :: BoxTree) :: Maybe ErrorMessage where - -- Zero or more - RuleApplies parent children ('SomeOptional other sub) = - 'Nothing - -- zero or one - RuleApplies parent (child ': others) ('OnceOptional child sub) = - If (Find child others) - ('Just ('Text "It is not allowed to have more than one '" - ':<>: 'ShowType child - ':<>: 'Text "' in '" - ':<>: 'ShowType parent - ':<>: 'Text "'.")) - 'Nothing - RuleApplies parent (notChild ': others) ('OnceOptional child sub) = - RuleApplies parent others ('OnceOptional child sub) - RuleApplies parent '[] ('OnceOptional child sub) = 'Nothing - -- exactly one - RuleApplies parent (child ': others) ('OnceMandatory child sub) = - If (Find child others) - ('Just ('Text "It is not allowed to have more than one '" - ':<>: 'ShowType child - ':<>: 'Text "' in '" - ':<>: 'ShowType parent - ':<>: 'Text "'.")) - 'Nothing - RuleApplies parent (notChild ': others) ('OnceMandatory child sub) = - RuleApplies parent others ('OnceMandatory child sub) - RuleApplies parent '[] ('OnceMandatory child sub) = - 'Just ('Text "Need exactly one '" - ':<>: 'ShowType child - ':<>: 'Text "' in '" - ':<>: 'ShowType parent - ':<>: 'Text "'.") - -- OnceMandatory or more - RuleApplies parent (child ': others) ('SomeMandatory child sub) = - 'Nothing - RuleApplies parent (notChild ': others) ('SomeMandatory child sub) = - RuleApplies parent others ('SomeMandatory child sub) - RuleApplies parent '[] ('SomeMandatory child sub) = - 'Just ('Text "Need at least one '" - ':<>: 'ShowType child - ':<>: 'Text "' in '" - ':<>: 'ShowType parent - ':<>: 'Text "'.") diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataInformation.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataInformation.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataInformation.hs @@ -0,0 +1,18 @@ +-- | Data information container declare the location of media information of a +-- 'Track' the actual location are stored in 'DataReference's. +module Data.ByteString.IsoBaseFileFormat.Boxes.DataInformation where + +import Data.ByteString.IsoBaseFileFormat.Boxes.Box + +-- | Data information box phantom type. +data DataInformation + +-- | Compose a 'DataInformation' box. +dataInformation + :: Boxes ts -> Box (ContainerBox DataInformation ts) +dataInformation = containerBox () + +instance IsBox DataInformation where + type BoxContent DataInformation = () + +type instance BoxTypeSymbol DataInformation = "dinf" diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataReference.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataReference.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataReference.hs @@ -0,0 +1,79 @@ +-- | A table of data references (URL/URNs). This tables is referred to by the +-- 'SampleDescription' this supports splitting a file over several files. When a +-- media file is split for transportation, this still counts as being in the +-- same file as the. +module Data.ByteString.IsoBaseFileFormat.Boxes.DataReference + (DataReference() + ,DataEntryUrl() + ,DataEntryUrn() + ,dataReference + ,localMediaDataReference + ,localMediaDataEntryUrl + ,dataEntryUrl + ,dataEntryUrn + ) + where + +import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox +import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields + hiding (Default) +import qualified Data.Text as T +import Data.Singletons.Prelude.List (Length) +import Data.Default + +-- | A container for 'DataEntryUrl's and 'DataEntryUrn's +newtype DataReference = + DataReference (U32 "entry_count") + deriving (Default,IsBoxContent) + +-- | A container for a URL +newtype DataEntryUrl = + DataEntryUrl (Maybe T.Text) + deriving (Default,IsBoxContent) + +-- | A container for a URN and optionally a URL +newtype DataEntryUrn = + DataEntryUrn (T.Text :+ T.Text) + deriving (IsBoxContent) + +-- | Create a 'DataReference' box. +dataReference + :: KnownNat (Length ts) + => Boxes ts -> Box (ContainerBox (FullBox DataReference 0) ts) +dataReference bs = + containerBox (FullBox 0 $ DataReference (typeListLength bs)) + bs + +-- | Create a 'DataReference' box with a single local media entry. +localMediaDataReference + :: Box (ContainerBox (FullBox DataReference 0) '[Box (FullBox DataEntryUrl 0)]) +localMediaDataReference = dataReference (singletonBox localMediaDataEntryUrl) + +-- | Create a 'DataEntryUrl' box for local media entry with the flag set and +-- empty content. +localMediaDataEntryUrl + :: Box (FullBox DataEntryUrl 0) +localMediaDataEntryUrl = dataEntryUrl True Nothing + +-- | Create a 'DataEntryUrl' box. The flag determines if the url is local, i.e. +-- the media data is in the same file. +dataEntryUrl + :: Bool -> Maybe T.Text -> Box (FullBox DataEntryUrl 0) +dataEntryUrl isLocal Nothing = Box (FullBox (fromIntegral $ fromEnum isLocal) $ DataEntryUrl Nothing) +dataEntryUrl isLocal murl = Box (FullBox (fromIntegral $ fromEnum isLocal) $ DataEntryUrl murl) + +-- | Create a 'DataEntryUrn' box. The flag determines if the url is local, i.e. +-- the media data is in the same file. +dataEntryUrn + :: Bool -> T.Text -> T.Text -> Box (FullBox DataEntryUrn 0) +dataEntryUrn isLocal urn url = Box (FullBox (fromIntegral $ fromEnum isLocal) $ DataEntryUrn $ urn :+ url) + +instance IsBox DataReference +type instance BoxTypeSymbol DataReference = "dref" + +instance IsBox DataEntryUrn +type instance BoxTypeSymbol DataEntryUrn = "urn " + +instance IsBox DataEntryUrl +type instance BoxTypeSymbol DataEntryUrl = "urn " diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/FileType.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/FileType.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/FileType.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/FileType.hs @@ -3,15 +3,14 @@ import Data.ByteString.IsoBaseFileFormat.Boxes.Box -- | File Type Box -instance IsBoxType FileType where +instance IsBox FileType where type BoxContent FileType = FileType - toBoxType _ _ = StdType "ftyp" +type instance BoxTypeSymbol FileType = "ftyp" -- | Create a 'FileTypeBox' from a major brand, a minor version and a list of -- compatible brands -fileTypeBox :: (ValidBox b FileType) - => FileType -> Box b FileType -fileTypeBox = closedBox +fileTypeBox :: FileType -> Box FileType +fileTypeBox = Box -- | Contents of a 'ftyp' box are some 'FourCc' /brands/ and a version. data FileType = diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/FullBox.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/FullBox.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/FullBox.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/FullBox.hs @@ -1,39 +1,39 @@ -- | Full Boxes module Data.ByteString.IsoBaseFileFormat.Boxes.FullBox - (FullBox(..), fullBox, closedFullBox, BoxVersion, BoxFlags(..)) + (FullBox(..), fullBox, BoxFlags(..)) where import Data.ByteString.IsoBaseFileFormat.Boxes.Box -import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields -- | A 'FullBox' contains an extra version and a flags field. In this -- implementation it is wrapped around the rest of the box content. This -- enforces that the 'FullBox' header fields are always at the beginning - at -- least as long as this module hides the 'FullBox' constructor ;) -data FullBox version t where - FullBox :: - BoxVersion version -> BoxFlags 24 -> t -> FullBox version t +data FullBox t (version :: Nat) where + FullBox :: (KnownNat version, IsBox t) + => BoxFlags 24 + -> BoxContent t + -> FullBox t version -instance (KnownNat version,IsBoxContent t) => IsBoxContent (FullBox version t) where - boxSize (FullBox _ f c) = 1 + boxSize f + boxSize c - boxBuilder (FullBox v f c) = boxBuilder v <> boxBuilder f <> boxBuilder c +instance (KnownNat v, IsBox t) => IsBox (FullBox t v) where + type BoxContent (FullBox t v) = FullBox t v --- | Create a 'FullBox' from a 'BoxVersion' and 'BoxFlags' -fullBox - :: (IsBoxType t,ValidContainerBox brand t ts,BoxContent t ~ FullBox version c) - => BoxVersion version -> BoxFlags 24 -> c -> Boxes brand ts -> Box brand t -fullBox version fs cnt = Box (FullBox version fs cnt) +type instance BoxTypeSymbol (FullBox t v) = BoxTypeSymbol t --- | Create a 'FullBox' from a 'BoxVersion' and 'BoxFlags' without nested boxes. -closedFullBox - :: (IsBoxType t,ValidBox brand t,BoxContent t ~ FullBox version c) - => BoxVersion version -> BoxFlags 24 -> c -> Box brand t -closedFullBox version fs cnt = closedBox (FullBox version fs cnt) +instance (IsBox t, KnownNat v) => IsBoxContent (FullBox t v) where + boxSize (FullBox f c) = 1 + boxSize f + boxSize c + boxBuilder (FullBox f c) = + word8 (fromIntegral (natVal (Proxy :: Proxy v))) + <> boxBuilder f + <> boxBuilder c --- | The box version (in a 'FullBox') is a single byte -type BoxVersion v = Template (U8 "fullbox-version") v +-- | Create a 'FullBox' from a 'BoxVersion' and 'BoxFlags' +fullBox + :: (KnownNat v, IsBox t) + => BoxFlags 24 -> BoxContent t -> Box (FullBox t v) +fullBox f c = Box (FullBox f c) --- | In addition to a 'BoxVersion' there can be 24 bits for custom flags etc in +-- | In addition to a version there can be 24 bits for custom flags etc in -- a 'FullBox'. newtype BoxFlags bits = BoxFlags Integer diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Handler.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Handler.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Handler.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Handler.hs @@ -26,15 +26,15 @@ | TimedMetadataTrack | AuxilliaryVideoTrack --- | Create a 'MediaDataBox' from a strict 'ByteString' +-- | Create a 'Handler' box. handler - :: (ValidBox brand Handler) - => Handler -> Box brand Handler -handler = closedFullBox Default 0 + :: Handler -> Box (FullBox Handler 0) +handler = fullBox 0 -instance IsBoxType Handler where - type BoxContent Handler = FullBox 0 Handler - toBoxType _ _ = StdType "hdlr" +instance IsBox Handler where + type BoxContent Handler = Handler + +type instance BoxTypeSymbol Handler = "hdlr" instance Default HandlerType where def = AudioTrack diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Media.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Media.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Media.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Media.hs @@ -6,10 +6,11 @@ -- | Media data box data Media -instance IsBoxType Media where - toBoxType _ _ = StdType "mdia" +instance IsBox Media where + type BoxContent Media = () +type instance BoxTypeSymbol Media = "mdia" + -- | Create a 'MediaDataBox' from a strict 'ByteString' -media :: ValidContainerBox brand Media ts - => Boxes brand ts -> Box brand Media -media = containerBox +media :: Boxes ts -> Box (ContainerBox Media ts) +media = containerBox () diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaData.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaData.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaData.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaData.hs @@ -5,13 +5,15 @@ import qualified Data.ByteString as B -- | Media data box phantom type -data MediaData +newtype MediaData = MediaData B.ByteString + deriving (Show, IsBoxContent) -instance IsBoxType MediaData where +instance IsBox MediaData where -- | Contents of a 'mdat' box are just bytes from a strict 'ByteString' - type BoxContent MediaData = B.ByteString - toBoxType _ _ = StdType "mdat" + type BoxContent MediaData = MediaData +type instance BoxTypeSymbol MediaData = "mdat" + -- | Create a 'MediaDataBox' from a strict 'ByteString' -mediaData :: ValidBox b MediaData => B.ByteString -> Box b MediaData -mediaData = closedBox +mediaData :: MediaData -> Box MediaData +mediaData = Box diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaHeader.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaHeader.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaHeader.hs @@ -16,13 +16,13 @@ -- | Create a 'MediaHeader' box. mediaHeader - :: (KnownNat v, ValidBox brand (MediaHeader v)) - => MediaHeader v -> Box brand (MediaHeader v) -mediaHeader = closedFullBox Default 0 + :: (KnownNat v) + => MediaHeader v -> Box (FullBox (MediaHeader v) v) +mediaHeader = fullBox 0 -instance (KnownNat v) => IsBoxType (MediaHeader v) where - type BoxContent (MediaHeader v) = FullBox v (MediaHeader v) - toBoxType _ _ = StdType "mdhd" +instance IsBox (MediaHeader v) + +type instance BoxTypeSymbol (MediaHeader v) = "mdhd" instance IsBoxContent (MediaHeader v) where boxSize (MediaHeader c) = boxSize c diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaInformation.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaInformation.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaInformation.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaInformation.hs @@ -4,14 +4,15 @@ import Data.ByteString.IsoBaseFileFormat.Boxes.Box --- | Media information box phantom type. +-- | Media information box type. data MediaInformation --- | Create a 'MediaInformation' from a strict 'ByteString' +-- | Compose a 'MediaInformation' box. mediaInformation - :: ValidContainerBox brand MediaInformation ts - => Boxes brand ts -> Box brand MediaInformation -mediaInformation = containerBox + :: Boxes ts -> Box (ContainerBox MediaInformation ts) +mediaInformation = containerBox () -instance IsBoxType MediaInformation where - toBoxType _ _ = StdType "minf" +instance IsBox MediaInformation where + type BoxContent MediaInformation = () + +type instance BoxTypeSymbol MediaInformation = "minf" diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Movie.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Movie.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Movie.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Movie.hs @@ -4,14 +4,15 @@ import Data.ByteString.IsoBaseFileFormat.Boxes.Box -- | Compose a set of boxes into a 'Movie' -movie :: (ValidContainerBox brand Movie ts) - => Boxes brand ts -> Box brand Movie -movie = containerBox +movie :: Boxes ts -> Box (ContainerBox Movie ts) +movie = containerBox () -- | The metadata for a presentation, a single 'Movie' which occurs only once -- and top-level. It is pretty empty on it's own, but it contains nested boxes -- with all the relevant meta data. data Movie -instance IsBoxType Movie where - toBoxType _ _ = StdType "moov" +instance IsBox Movie where + type BoxContent Movie = () + +type instance BoxTypeSymbol Movie = "moov" diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieHeader.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieHeader.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieHeader.hs @@ -10,9 +10,9 @@ -- | Construct a 'MovieHeader' box. movieHeader - :: (KnownNat version, ValidBox brand (MovieHeader version)) - => MovieHeader version -> Box brand (MovieHeader version) -movieHeader = closedFullBox Default 0 + :: (KnownNat version) + => MovieHeader version -> Box (FullBox (MovieHeader version) version) +movieHeader = fullBox 0 -- | Movie meta data, indexed by a version. -- @@ -61,6 +61,6 @@ boxSize (MovieHeader c) = boxSize c boxBuilder (MovieHeader c) = boxBuilder c -instance KnownNat version => IsBoxType (MovieHeader version) where - toBoxType _ _ = StdType "mvhd" - type BoxContent (MovieHeader version) = FullBox version (MovieHeader version) +instance IsBox (MovieHeader version) + +type instance BoxTypeSymbol (MovieHeader v) = "mvhd" diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/ProgressiveDownloadInformation.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/ProgressiveDownloadInformation.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/ProgressiveDownloadInformation.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/ProgressiveDownloadInformation.hs @@ -8,16 +8,16 @@ -- | A Box with progressive download information data ProgressiveDownload -instance IsBoxType ProgressiveDownload where - type BoxContent ProgressiveDownload = FullBox 0 ProgressiveDownloadContent - toBoxType _ _ = StdType "pdin" +instance IsBox ProgressiveDownload where + type BoxContent ProgressiveDownload = ProgressiveDownloadContent +type instance BoxTypeSymbol ProgressiveDownload = "pdin" + -- | Information for progressive media data download/playback encompasses the -- delay for initial playback and expected download bit rate. type ProgressiveDownloadContent = U32 "rate" :+ U32 "delay" -- | Construct a @pdin@ box. pdinBox - :: ValidBox brand ProgressiveDownload - => ProgressiveDownloadContent -> Box brand ProgressiveDownload -pdinBox = closedFullBox Default 0 + :: ProgressiveDownloadContent -> Box (FullBox ProgressiveDownload 0) +pdinBox = fullBox 0 diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Skip.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Skip.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Skip.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Skip.hs @@ -6,13 +6,14 @@ -- | Contents of a 'skip' box are just any number of filler bytes. newtype Skip = Skip Int -instance IsBoxType Skip where +instance IsBox Skip where type BoxContent Skip = Skip - toBoxType _ _ = StdType "skip" +type instance BoxTypeSymbol Skip = "skip" + -- | Create a 'Skip' with a given size. -skipBox :: ValidBox brand Skip => Skip -> Box brand Skip -skipBox = closedBox +skipBox :: Skip -> Box Skip +skipBox = Box instance IsBoxContent Skip where boxSize (Skip bs) = fromIntegral bs diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/SpecificMediaHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SpecificMediaHeader.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/SpecificMediaHeader.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SpecificMediaHeader.hs @@ -4,48 +4,76 @@ import Data.ByteString.IsoBaseFileFormat.Boxes.Box import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox +import Data.Default --- | Media header data box. The actual box type is determined by the claused --- used to construct the record. -data SpecificMediaHeader where +-- * Videos + +-- | Video header data box. +newtype VideoMediaHeader where VideoMediaHeader :: Template (U16 "graphicsmode") 0 - :+ Template (U16 "reserved") 0 - -> SpecificMediaHeader + :+ Template (U16Arr "opcolor" 3) '[0,0,0] + -> VideoMediaHeader + deriving (Default, IsBoxContent) + +-- | Create a video media header data box. +videoMediaHeader :: VideoMediaHeader -> Box (FullBox VideoMediaHeader 0) +videoMediaHeader = fullBox 1 + +instance IsBox VideoMediaHeader +type instance BoxTypeSymbol VideoMediaHeader = "vmhd" + +-- * Sounds + +-- | Sound header data box. +newtype SoundMediaHeader where SoundMediaHeader :: Template (I16 "balance") 0 - :+ Constant (U16Arr "opcolor" 3) '[0,0,0] - -> SpecificMediaHeader + :+ Constant (U16 "reserved") 0 + -> SoundMediaHeader + deriving (Default, IsBoxContent) + +-- | Create a sound media header data box. +soundMediaHeader :: SoundMediaHeader -> Box (FullBox SoundMediaHeader 0) +soundMediaHeader = fullBox 0 + +instance IsBox SoundMediaHeader +type instance BoxTypeSymbol SoundMediaHeader = "smhd" + +-- * Hints + +-- | Hint data box. +newtype HintMediaHeader where HintMediaHeader :: U16 "maxPDUsize" :+ U16 "avgPDUsize" :+ U16 "maxbitrate" :+ U16 "avgbitrate" :+ U32 "reserved" - -> SpecificMediaHeader - NullMediaHeader - :: SpecificMediaHeader + -> HintMediaHeader + deriving (Default, IsBoxContent) --- | Create a 'SpecificMediaHeader' box. -specificMediaHeader - :: ValidBox brand SpecificMediaHeader - => SpecificMediaHeader -> Box brand SpecificMediaHeader -specificMediaHeader h@(VideoMediaHeader _) = closedFullBox Default 1 h -specificMediaHeader h = closedFullBox Default 0 h +-- | Create a hint media header data box. +hintMediaHeader :: HintMediaHeader -> Box (FullBox HintMediaHeader 0) +hintMediaHeader = fullBox 0 -instance IsBoxType SpecificMediaHeader where - type BoxContent SpecificMediaHeader = FullBox 0 SpecificMediaHeader - toBoxType _ (FullBox _ _ (VideoMediaHeader _)) = StdType "vmhd" - toBoxType _ (FullBox _ _ (SoundMediaHeader _)) = StdType "smhd" - toBoxType _ (FullBox _ _ (HintMediaHeader _)) = StdType "hmhd" - toBoxType _ (FullBox _ _ NullMediaHeader) = StdType "nmhd" +instance IsBox HintMediaHeader +type instance BoxTypeSymbol HintMediaHeader = "hmhd" -instance IsBoxContent SpecificMediaHeader where - boxSize (VideoMediaHeader c) = boxSize c - boxSize (SoundMediaHeader c) = boxSize c - boxSize (HintMediaHeader c) = boxSize c - boxSize NullMediaHeader = boxSize () - boxBuilder (VideoMediaHeader c) = boxBuilder c - boxBuilder (SoundMediaHeader c) = boxBuilder c - boxBuilder (HintMediaHeader c) = boxBuilder c - boxBuilder NullMediaHeader = boxBuilder () +-- * Dummy/Null media + +-- | Null header data box. +data NullMediaHeader = NullMediaHeader + +-- | Create a null media header data box. +nullMediaHeader :: Box (FullBox NullMediaHeader 0) +nullMediaHeader = fullBox 0 NullMediaHeader + +instance IsBox NullMediaHeader +type instance BoxTypeSymbol NullMediaHeader = "nmhd" + +instance Default NullMediaHeader where + def = NullMediaHeader +instance IsBoxContent NullMediaHeader where + boxSize _ = 0 + boxBuilder _ = mempty diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Track.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Track.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Track.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Track.hs @@ -6,12 +6,13 @@ -- * @trak@ Box -- | Compose a 'Track' box from the given boxes. track - :: (ValidContainerBox brand Track ts) - => Boxes brand ts -> Box brand Track -track = containerBox + :: Boxes ts -> Box (ContainerBox Track ts) +track = containerBox () -- | Container box for tracks. data Track -instance IsBoxType Track where - toBoxType _ _ = StdType "trak" +instance IsBox Track where + type BoxContent Track = () + +type instance BoxTypeSymbol Track = "trak" diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackHeader.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackHeader.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackHeader.hs @@ -9,9 +9,9 @@ -- * @tkhd@ Box -- | Create a 'TrackHeader' box. trackHeader - :: (ValidBox brand (TrackHeader version), version ~ GetVersion brand) - => TrackHeader version -> Box brand (TrackHeader version) -trackHeader = closedFullBox Default 0 + :: KnownNat version + => TrackHeader version -> Box (FullBox (TrackHeader version) version) +trackHeader = fullBox 0 -- | Track meta data, indexed by a version. data TrackHeader (version :: Nat) where @@ -46,6 +46,6 @@ boxSize (TrackHeader c) = boxSize c boxBuilder (TrackHeader c) = boxBuilder c -instance KnownNat version => IsBoxType (TrackHeader version) where - type BoxContent (TrackHeader version) = FullBox version (TrackHeader version) - toBoxType _ _ = StdType "tkhd" +instance IsBox (TrackHeader version) + +type instance BoxTypeSymbol (TrackHeader version) = "tkhd" diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Versioned.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Versioned.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Versioned.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Versioned.hs @@ -1,10 +1,13 @@ +{-# LANGUAGE UndecidableInstances #-} -- | A binary version 0/1 field with seperate content for each version. module Data.ByteString.IsoBaseFileFormat.Boxes.Versioned - (Versioned(..)) + (Versioned(..), ApplyVersioned(..), SelectByVersion) where import Data.ByteString.IsoBaseFileFormat.Boxes.Box import Data.Default +import Data.Kind +import Data.Singletons -- | Two alternative representations based on a /version/ index. -- Use this for box content that can be either 32 or 64 bit. @@ -20,3 +23,39 @@ boxSize (V1 c) = boxSize c boxBuilder (V0 c) = boxBuilder c boxBuilder (V1 c) = boxBuilder c + +data VersionedBox c where + BoxV0 :: forall (v :: Nat -> Type). IsBoxContent (v 0) => v 0 -> VersionedBox v + BoxV1 :: forall (v :: Nat -> Type). IsBoxContent (v 1) => v 1 -> VersionedBox v + +instance (IsBoxContent (b 0), Default (b 0)) => Default (VersionedBox b) where + def = BoxV0 def + +instance IsBoxContent (VersionedBox c) where + boxSize (BoxV0 c) = boxSize c + boxSize (BoxV1 c) = boxSize c + boxBuilder (BoxV0 c) = boxBuilder c + boxBuilder (BoxV1 c) = boxBuilder c + +-- * Versions based on type level arrows + +-- | Two alternative representations based on a /version/ index. +-- Use this for box content that can be either 32 or 64 bit. +data ApplyVersioned (v' :: Nat ~> Type) where + OnV0 :: forall (v :: Nat ~> Type). IsBoxContent (v @@ 0) => v @@ 0 -> ApplyVersioned v + OnV1 :: forall (v :: Nat ~> Type). IsBoxContent (v @@ 1) => v @@ 1 -> ApplyVersioned v + +instance (IsBoxContent (b @@ 0), Default (b @@ 0)) => Default (ApplyVersioned b) where + def = OnV0 def + +instance IsBoxContent (ApplyVersioned c) where + boxSize (OnV0 c) = boxSize c + boxSize (OnV1 c) = boxSize c + boxBuilder (OnV0 c) = boxBuilder c + boxBuilder (OnV1 c) = boxBuilder c + +-- | A type level arrow that applys the type constructor to one of the two +-- versions depending on the /version/ parameter. +data SelectByVersion :: (a -> Type) -> a -> a -> Nat ~> Type +type instance Apply (SelectByVersion f v0 v1) 0 = f v0 +type instance Apply (SelectByVersion f v0 v1) 1 = f v1 diff --git a/src/Data/ByteString/IsoBaseFileFormat/Brands/Dash.hs b/src/Data/ByteString/IsoBaseFileFormat/Brands/Dash.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Brands/Dash.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Brands/Dash.hs @@ -1,32 +1,64 @@ +{-# LANGUAGE UndecidableInstances #-} -- | Predefined Box composition matching the @dash@ brand. TODO this is an -- incomplete, special-purpose variant of this brand, serving my personal, -- educational, current need. -- This is a convenient way of building documents of that kind. module Data.ByteString.IsoBaseFileFormat.Brands.Dash - (Dash, SingleTrackInit(..), mkSingleTrackInit, module X) where + (Dash, SingleAudioTrackInit(..), mkSingleTrackInit, module X) where -import Data.ByteString.IsoBaseFileFormat.Boxes as X +import Data.ByteString.IsoBaseFileFormat.Brands.Types +import Data.ByteString.IsoBaseFileFormat.Boxes as X hiding (All) import Data.Kind (Type, Constraint) import Control.Lens +import Data.Promotion.Prelude.List +import Data.Singletons -- | A phantom type to indicate this branding. Version can be 0 or 1 it is used -- in some boxes to switch between 32/64 bits. data Dash (version :: Nat) +-- | A constant to indicate the 'Dash' brand with version 0 +dash :: Proxy (Dash 0) +dash = Proxy + -- | A 'BoxLayout' which contains the stuff needed for the 'dash' brand. -- TODO incomplete -instance KnownNat v => IsBrand (Dash v) where - type GetVersion (Dash v) = v +instance IsBrand (Dash v) where type BoxLayout (Dash v) = - '[OM_ FileType, - OM Movie - '[OM_ (MovieHeader v), - SM Track - '[OM_ (TrackHeader v), - OM Media - '[OM_ (MediaHeader v), OM_ Handler, - OM MediaInformation '[OO_ SpecificMediaHeader]]]], - SO_ Skip] + Boxes + '[ OM_ FileType + , OM Movie + '[ OM_ (MovieHeader v) + , SM Track + '[ OM_ (TrackHeader v) + , OM Media + '[ OM_ (MediaHeader v) + , OM_ Handler + , OM MediaInformation + '[ OneOf '[ OM_ VideoMediaHeader + , OM_ SoundMediaHeader + , OM_ HintMediaHeader + , OM_ NullMediaHeader] + , OM DataInformation + '[ OM DataReference + '[ OneOf '[ OM_ DataEntryUrl + , OM_ DataEntryUrn] + , SomeOptionalX + (OneOf '[ OM_ DataEntryUrl + , OM_ DataEntryUrn])]] + -- , OM (SampleTable v) -- TODO + -- '[ OM_ (SampleDescriptions v) + -- , OM_ (TimeToSample v) + -- , OM_ (SampleToChunk v) + -- , OO_ (SampleSizes v) + -- , OM_ (SampleChunkOffset v) + -- ] + ] + ] + ] + ] + , SO_ Skip + ] -- Missing Boxes -- START 17:47: @@ -58,23 +90,23 @@ -- trun -- | A record which contains the stuff needed for a single track initialization -- document according to the 'Dash' brand. TODO incomplete -data SingleTrackInit = - SingleTrackInit {_mvhd :: MovieHeader 0 - ,_tkhd :: TrackHeader 0 - ,_mdhd :: MediaHeader 0 - ,_hdlr :: Handler - ,_xmhd :: SpecificMediaHeader} +data SingleAudioTrackInit = + SingleAudioTrackInit {_mvhd :: MovieHeader 0 + ,_tkhd :: TrackHeader 0 + ,_mdhd :: MediaHeader 0 + ,_hdlr :: Handler + ,_smhd :: SoundMediaHeader} -makeLenses ''SingleTrackInit +makeLenses ''SingleAudioTrackInit --- | Convert a 'SingleTrackInit' record to a generic 'Boxes' collection. +-- | Convert a 'SingleAudioTrackInit' record to a generic 'Boxes' collection. mkSingleTrackInit - :: SingleTrackInit -> MediaFile (Dash 0) -mkSingleTrackInit doc = - MediaFile $ - fileTypeBox (FileType "iso5" 0 ["isom","iso5","dash","mp42"]) :| - movie (movieHeader (doc ^. mvhd) :| - track (trackHeader (doc ^. tkhd) :| - media (mediaHeader (doc ^. mdhd) :. handler (doc ^. hdlr) :| - mediaInformation $: - specificMediaHeader (doc ^. xmhd)))) + :: SingleAudioTrackInit -> Builder +mkSingleTrackInit doc = mediaBuilder dash $ + fileTypeBox (FileType "dash" 0 ["isom","iso5","mp42"]) + :| + movie (movieHeader (doc ^. mvhd) :| + track (trackHeader (doc ^. tkhd) :| + media (mediaHeader (doc ^. mdhd) :. handler (doc ^. hdlr) :| + mediaInformation + (soundMediaHeader (doc ^. smhd) :| dataInformation $: localMediaDataReference )))) diff --git a/src/Data/ByteString/IsoBaseFileFormat/Brands/Types.hs b/src/Data/ByteString/IsoBaseFileFormat/Brands/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/IsoBaseFileFormat/Brands/Types.hs @@ -0,0 +1,16 @@ +-- | Brand/Box-validation +module Data.ByteString.IsoBaseFileFormat.Brands.Types + where + +import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.ByteString.IsoBaseFileFormat.Util.TypeLayout () + +-- | A class that describes (on the type level) how a box can be nested into +-- other boxes (see 'Boxes). +class IsBrand brand where + -- | The layout that an IsBoxContent instance has to have, before 'packMedia' accepts it + type BoxLayout brand + mediaBuilder + :: forall t proxy . (IsBoxContent t, IsRuleConform t (BoxLayout brand) ~ 'True) + => proxy brand -> t -> Builder + mediaBuilder _ t = boxBuilder t diff --git a/src/Data/ByteString/IsoBaseFileFormat/Util/TypeLayout.hs b/src/Data/ByteString/IsoBaseFileFormat/Util/TypeLayout.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/IsoBaseFileFormat/Util/TypeLayout.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Data.ByteString.IsoBaseFileFormat.Util.TypeLayout where + +import Data.Kind +import Data.Type.Bool +import Data.Singletons (Apply, type (~>)) +import Data.Type.Equality +import GHC.TypeLits + +---- +type family IsRuleConform (b :: k) (r :: l) :: Bool +data IsRuleConform0 :: k ~> l ~> Bool +type instance Apply IsRuleConform0 ts = IsRuleConform1 ts +data IsRuleConform1 :: k -> l ~> Bool +type instance Apply (IsRuleConform1 ts) rule = IsRuleConform ts rule +---- +data TopLevel :: Type -> Type +type instance IsRuleConform t (TopLevel rule) = IsRuleConform t rule +---- +data OneOf :: [Type] -> Type +type instance IsRuleConform t (OneOf '[]) = 'False +type instance IsRuleConform t (OneOf (r ': rs)) = + IsRuleConform t r || IsRuleConform t (OneOf rs) +---- +data MatchSymbol :: Symbol -> Type +type instance IsRuleConform b (MatchSymbol fourcc) = ToSymbol b == fourcc +type family ToSymbol t :: Symbol +data ToSymbol0 :: Type ~> Symbol +type instance Apply ToSymbol0 t = ToSymbol t +---- +data OnceOptionalX t +data SomeOptionalX t +data SomeMandatoryX t +type instance IsRuleConform (bs :: [Type]) (sq :: [Type]) = IsSequence bs sq +type family + IsSequence (bs :: [k]) (rs :: [j]) :: Bool + where + IsSequence '[] '[] = 'True + IsSequence (b ': bs) '[] = 'False + -- + IsSequence '[] (OnceOptionalX r ': rs) = IsSequence '[] rs + IsSequence (b ': bs) (OnceOptionalX r ': rs) = + If (IsRuleConform b r) + (IsSequence bs rs) + (IsSequence (b ': bs) rs) + -- + IsSequence '[] (SomeOptionalX r ': rs) = IsSequence '[] rs + IsSequence (b ': bs) (SomeOptionalX r ': rs) = + If (IsRuleConform b r) + (IsSequence bs (SomeOptionalX r ': rs)) + (IsSequence (b ': bs) rs ) + -- + IsSequence '[] (SomeMandatoryX r ': rs) = 'False + IsSequence (b ': bs) (SomeMandatoryX r ': rs) = + IsRuleConform b r && IsSequence bs (SomeOptionalX r ': rs) + -- + IsSequence '[] (r ': rs) = 'False + IsSequence (b ': bs) (r ': rs) = + IsRuleConform b r && IsSequence bs rs