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.3.0.0 +version: 0.9.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 @@ -15,21 +15,37 @@ library hs-source-dirs: src - exposed-modules: Data.ByteString.IsoBaseFileFormat.Builder + 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.FileType , Data.ByteString.IsoBaseFileFormat.Boxes.FullBox + , Data.ByteString.IsoBaseFileFormat.Boxes.Handler + , Data.ByteString.IsoBaseFileFormat.Boxes.Media , Data.ByteString.IsoBaseFileFormat.Boxes.MediaData - , Data.ByteString.IsoBaseFileFormat.Boxes.Skip + , Data.ByteString.IsoBaseFileFormat.Boxes.MediaHeader + , Data.ByteString.IsoBaseFileFormat.Boxes.MediaInformation + , Data.ByteString.IsoBaseFileFormat.Boxes.Movie + , Data.ByteString.IsoBaseFileFormat.Boxes.MovieHeader , Data.ByteString.IsoBaseFileFormat.Boxes.ProgressiveDownloadInformation - , Data.ByteString.IsoBaseFileFormat.Boxes.MovieBox + , Data.ByteString.IsoBaseFileFormat.Boxes.Language + , Data.ByteString.IsoBaseFileFormat.Boxes.Skip + , Data.ByteString.IsoBaseFileFormat.Boxes.SpecificMediaHeader + , Data.ByteString.IsoBaseFileFormat.Boxes.Time + , Data.ByteString.IsoBaseFileFormat.Boxes.Track + , Data.ByteString.IsoBaseFileFormat.Boxes.TrackHeader + , Data.ByteString.IsoBaseFileFormat.Boxes.Versioned + , Data.ByteString.IsoBaseFileFormat.Brands.Dash build-depends: base >= 4.9 && < 5 - , bytestring >= 0.10.8.1 - , type-list >= 0.5.0.0 - -- , mtl - , vector-sized >= 0.3.2.0 - , singletons >= 2.2 + , bytestring >= 0.10.8.1 && < 0.11 + , type-list >= 0.5.0.0 && < 0.6 + , data-default >= 0.7.1.1 && < 0.8 + , vector-sized >= 0.3.2.0 && < 0.4 + , singletons >= 2.2 && < 3 + , lens >= 4.14 && < 5 + , time >= 1.6.0.1 && < 2 + , text >= 1.2.2.1 && < 2 default-language: Haskell2010 ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind default-extensions: ConstraintKinds @@ -67,11 +83,13 @@ main-is: Spec.hs other-modules: BoxFieldsSpec , BoxSpec + , DashSpec build-depends: base >= 4.9 && < 5 , bytestring >= 0.10.8.1 , hspec , isobmff-builder , binary + , text >= 1.2.2.1 && < 2 default-language: Haskell2010 default-extensions: ConstraintKinds , CPP diff --git a/spec/BoxFieldsSpec.hs b/spec/BoxFieldsSpec.hs --- a/spec/BoxFieldsSpec.hs +++ b/spec/BoxFieldsSpec.hs @@ -1,47 +1,80 @@ module BoxFieldsSpec (spec) where import Test.Hspec -import Data.ByteString.IsoBaseFileFormat.Builder +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 Control.Exception (evaluate) +import qualified Data.Text as T -- import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as BL import -- qualified Data.Binary.Get as Binary - spec :: Spec spec = - describe "Scalar, Constant, Template and ScalarArry composition" $ - describe "IsBoxContent instances" $ - do describe "example1" $ - do it "boxSize reports the correct size" $ - boxSize example1 `shouldBe` (1 + 1 + (3 * 8) + (7 * 8)) - it "crashes during rendering because of the invalid number of array elements for \"baz\"" $ - evaluate (renderBox example1') `shouldThrow` anyException - describe "example2" $ - do it "boxSize reports the correct size" $ - boxSize example2 `shouldBe` (2 * 4 + 2 + 2 + 2 + 2 + 9 * 4 + 4 + 4) - it "it renders the expected content" $ - renderBox example2 `shouldBe` (BL.pack [0,0,0,0, - 0,0,0,0, - 0,65, - 0,66, - 1,0, - 0,0, - 0,0,0,67, - 0,0,0,68, - 0,0,0,69, - 0,0,0,70, - 0,0,0,71, - 0,0,0,72, - 0,0,0,73, - 0,0,0,74, - 0,0,0,75, - 0,0,0,76, - 0,0,0,77]) + 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 it "throws runtime exceptions when the code is too short or too long" $ + do evaluate (mkLanguage "") `shouldThrow` anyException + evaluate (mkLanguage "a") `shouldThrow` anyException + evaluate (mkLanguage "aa") `shouldThrow` anyException + evaluate (mkLanguage "bbbb") `shouldThrow` anyException + evaluate (mkLanguage "bbbbb") `shouldThrow` anyException + it "throws runtime exceptions when the code is not in aaa .. zzz" $ + do evaluate (mkLanguage "! 3") `shouldThrow` anyException + evaluate (mkLanguage "AAA") `shouldThrow` anyException + it "renders lower case three-letter strings correctly" $ + let actual = + BL.unpack (toLazyByteString (boxBuilder (mkLanguage "deu"))) + expected = + BL.unpack (toLazyByteString (word16BE (4 * 1024 + 5 * 32 + 21))) + in actual `shouldBe` expected + describe "Scalar, Constant, Template and ScalarArry composition" $ + describe "IsBoxContent instances" $ + do describe "example1" $ + do it "boxSize reports the correct size" $ boxSize example1 `shouldBe` + (1 + 1 + (3 * 8) + (7 * 8)) + it "crashes during rendering because of the invalid number of array elements for \"baz\"" $ + evaluate (renderBox example1') `shouldThrow` + anyException + describe "example2" $ + do it "boxSize reports the correct size" $ boxSize example2 `shouldBe` + (2 * 4 + 2 + 2 + 2 + 2 + 9 * 4 + 4 + 4) + it "it renders the expected content" $ renderBox example2 `shouldBe` + (BL.pack [0 ,0 ,0 ,0 + ,0 ,0 ,0 ,0 + ,0 ,65 ,0 ,66 + ,1 ,0 ,0 ,0 + ,0 ,0 ,0 ,67 + ,0 ,0 ,0 ,68 + ,0 ,0 ,0 ,69 + ,0 ,0 ,0 ,70 + ,0 ,0 ,0 ,71 + ,0 ,0 ,0 ,72 + ,0 ,0 ,0 ,73 + ,0 ,0 ,0 ,74 + ,0 ,0 ,0 ,75 + ,0 ,0 ,0 ,76 + ,0 ,0 ,0 ,77]) -renderBox :: IsBoxContent c => c -> BL.ByteString +renderBox :: IsBoxContent c + => c -> BL.ByteString renderBox = toLazyByteString . boxBuilder type ExampleContent = Scalar Word8 "bla" :+ Constant (Scalar Word8 "blub") 123 :+ Template (ScalarArray "foos" 3 Int64) '[1, 2, 3] :+ ScalarArray "baz" 7 Word64 @@ -49,28 +82,16 @@ type ExampleContentShort = U8 "bla" :+ Constant (U8 "blub") 123 :+ Template (I64Arr "foos" 3) '[1, 2, 3] :+ U64Arr "baz" 7 example1 :: ExampleContent -example1 = Scalar 100 <+> Constant <+> Default <+> u64Arr [1,2,3] +example1 = Scalar 100 :+ Constant :+ Default :+ u64Arr [1,2,3] example1' :: ExampleContentShort example1' = example1 -type Example2 isAudio = - Constant (I32Arr "reserved" 2) '[0, 0] - :+ Template (I16 "layer") 0 - :+ Template (I16 "alternate_group") 0 - :+ Template (I16 "volume") (If isAudio 256 0) - :+ Constant (I16 "reserved") 0 - :+ Template (I32Arr "matrix" 9) '[65536, 0, 0, 0, 65536, 0, 0, 0, 1073741824] - :+ I32 "width" - :+ I32 "height" +type Example2 isAudio = Constant (I32Arr "reserved" 2) '[0, 0] :+ Template (I16 "layer") 0 :+ Template (I16 "alternate_group") 0 :+ Template (I16 "volume") (If isAudio 256 0) :+ Constant (I16 "reserved") 0 :+ Template (I32Arr "matrix" 9) '[65536, 0, 0, 0, 65536, 0, 0, 0, 1073741824] :+ I32 "width" :+ I32 "height" example2 :: Example2 'True example2 = - Constant <+> - Custom 65 <+> - Custom 66 <+> - Default <+> - Constant <+> - Custom (i32Arr [67 .. 75]) <+> - i32 76 <+> + Constant :+ Custom 65 :+ Custom 66 :+ Default :+ Constant :+ + Custom (i32Arr [67 .. 75]) :+ + i32 76 :+ i32 77 diff --git a/spec/BoxSpec.hs b/spec/BoxSpec.hs --- a/spec/BoxSpec.hs +++ b/spec/BoxSpec.hs @@ -1,7 +1,8 @@ module BoxSpec (spec) where import Test.Hspec -import Data.ByteString.IsoBaseFileFormat.Builder +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 @@ -22,10 +23,10 @@ do describe "boxSize" $ do describe "a box with one nested box" $ do it "returns the sum of both boxSizes" $ - boxSize (testParentBox1 $ Nested :. testBox1) `shouldBe` + boxSize (testParentBox1 $ singletonBox testBox1) `shouldBe` (2 * boxSize testBox1) it "returns the same value as written by boxBuilder" $ - let b = testParentBox1 $ Nested :. testBox1 + let b = testParentBox1 $ singletonBox testBox1 writtenSize = let out = toLazyByteString (boxBuilder b) getSize = Binary.runGet Binary.getWord32be @@ -33,25 +34,26 @@ reportedSize = boxSize b in writtenSize `shouldBe` reportedSize +data TestBrand -data TestBox1 +instance IsBrand TestBrand where + type BoxLayout TestBrand = + '[ 'OnceMandatory TestParentBox1 '[ 'SomeOptional TestBox1 '[]] ] -instance BoxRules TestBox1 where - type RestrictedTo TestBox1 = 'Nothing +data TestBox1 -instance IsBoxType' TestBox1 where - toBoxType' _ = StdType "tst1" +instance IsBoxType TestBox1 where + toBoxType _ _ = StdType "tst1" -testBox1 :: Box' TestBox1 +testBox1 :: Box TestBrand TestBox1 testBox1 = closedBox () - data TestParentBox1 -instance BoxRules TestParentBox1 - -instance IsBoxType' TestParentBox1 where - toBoxType' _ = StdType "par1" +instance IsBoxType TestParentBox1 where + toBoxType _ _ = StdType "par1" -testParentBox1 :: (ValidBoxes TestParentBox1 ts) => Boxes ts -> Box' TestParentBox1 +testParentBox1 + :: ValidContainerBox TestBrand TestParentBox1 ts + => Boxes TestBrand ts -> Box TestBrand TestParentBox1 testParentBox1 = containerBox diff --git a/spec/DashSpec.hs b/spec/DashSpec.hs new file mode 100644 --- /dev/null +++ b/spec/DashSpec.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE OverloadedStrings #-} +module DashSpec (spec) where + +import Test.Hspec +import Data.ByteString.IsoBaseFileFormat.Brands.Dash +import qualified Data.ByteString.Lazy as BL +import Data.Text () + +spec :: Spec +spec = + do describe "minimalIsobmff version 0" $ + do it "renders some output at all" $ + do createionTime <- mp4CurrentTime + let ct :: Word32 + ct = fromScalar createionTime + ct3 = (ct `shiftR` 24) .&. 255 + ct2 = (ct `shiftR` 16) .&. 255 + ct1 = (ct `shiftR` 8) .&. 255 + ct0 = (ct `shiftR` 0) .&. 255 + cts :: [Word8] + cts = fromIntegral <$> [ct3,ct2,ct1,ct0] + let args = exampleSingleTrackInit createionTime + doc = mkSingleTrackInit args + rendered = BL.unpack $ packMediaFile 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 + ,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 + ,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 + ,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] + -- BL.writeFile "/tmp/xxx.mp4" (BL.pack rendered) + rendered `shouldBe` + expected + +exampleSingleTrackInit :: U32 "creation_time" -> SingleTrackInit +exampleSingleTrackInit creationTime = + SingleTrackInit (MovieHeader $ + V0 (creationTime :+ 0 :+ Default :+ durationFromSeconds Default 1) :+ + def) + (TrackHeader $ + V0 (0 :+ 0 :+ 1 :+ Constant :+ durationFromSeconds Default 1) :+ + def) + (MediaHeader $ def) + (Handler $ def :+ AudioTrack :+ def :+ (Custom "Hello world!")) + (SoundMediaHeader def) diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes.hs @@ -0,0 +1,43 @@ +-- | This module re-exports all modules needed to build /ISOBMFF/ documents. +module Data.ByteString.IsoBaseFileFormat.Boxes + (module Data.ByteString.IsoBaseFileFormat.Boxes, module X) + where + +import Data.ByteString.IsoBaseFileFormat.Boxes.Box as X +import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields 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 +import Data.ByteString.IsoBaseFileFormat.Boxes.Media as X +import Data.ByteString.IsoBaseFileFormat.Boxes.MediaData as X +import Data.ByteString.IsoBaseFileFormat.Boxes.MediaHeader as X +import Data.ByteString.IsoBaseFileFormat.Boxes.MediaInformation as X +import Data.ByteString.IsoBaseFileFormat.Boxes.Movie as X +import Data.ByteString.IsoBaseFileFormat.Boxes.MovieHeader as X +import Data.ByteString.IsoBaseFileFormat.Boxes.ProgressiveDownloadInformation as X +import Data.ByteString.IsoBaseFileFormat.Boxes.Language as X +import Data.ByteString.IsoBaseFileFormat.Boxes.Skip as X +import Data.ByteString.IsoBaseFileFormat.Boxes.SpecificMediaHeader as X +import Data.ByteString.IsoBaseFileFormat.Boxes.Time as X +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) +import Data.Maybe as X +import Data.Type.Bool as X +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,45 +12,26 @@ (module Data.ByteString.IsoBaseFileFormat.Boxes.Box, module X) where +import Data.ByteString.IsoBaseFileFormat.Boxes.Brand as X import Data.Bits as X import Data.ByteString.Builder as X import Data.Monoid as X import Data.Proxy as X import Data.Word as X +import Data.Kind import GHC.TypeLits as X import Data.String -import Data.Type.Equality -import Data.Type.List -import Data.Type.Bool +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Singletons.Prelude.List ((:++)) import qualified Data.ByteString as B --- * Basic Types and classes - +-- * Box Type Classes -- | Base class for all (abstract/phantom/normal-) types that represent boxes -class (IsBoxContent (BoxContent t), BoxRules t) => IsBoxType' t where +class (IsBoxContent (BoxContent t)) => IsBoxType t where type BoxContent t type BoxContent t = () - toBoxType' :: proxy t -> BoxType - --- | A class that describes (on the type level) how a box can be nested into --- other boxes (see 'Boxes). -class BoxRules (t :: k) where - -- | List of boxes that this box can be nested into. - type RestrictedTo t :: Maybe [k] - type RestrictedTo t = 'Just '[] - -- | If the box is also allowed 'top-level' i.e. in the file directly, not - -- nested in an other box. - type IsTopLevelBox t :: Bool - type IsTopLevelBox t = 'True - -- | Describes which nested boxes MUST be present in a box using 'boxes'. - type RequiredNestedBoxes t :: [k] - type RequiredNestedBoxes t = '[] - -- | Describes how many times a box should be present in a container (-box). - type GetCardinality t (c :: k) :: Cardinality - type GetCardinality t any = 'ExactlyOnce - --- | Describes how many times a box should be present in a container. -data Cardinality = AtMostOnce | ExactlyOnce | OnceOrMore + toBoxType :: proxy t -> BoxContent t -> BoxType -- | 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 @@ -60,57 +41,72 @@ boxBuilder :: a -> Builder -- * Data types - -- | A type that wraps the contents of a box and the box type. -data Box' b where - Box' :: (IsBoxType' b, ValidBoxes b ts) => BoxContent b -> Boxes ts -> Box' b +data Box brand b where + Box :: + (IsBoxType b, IsBrandConform brand ('Just b) ts) => + BoxContent b -> Boxes brand ts -> Box brand b -instance IsBoxContent (Box' cnt) where - boxBuilder b@(Box' cnt nested) = sB <> tB <> sExtB <> tExtB <> cntB <> nestedB - where s = boxSize b - t = toBoxType' b - sB = boxBuilder s - sExtB = boxBuilder (BoxSizeExtension s) - tB = boxBuilder t - tExtB = boxBuilder (BoxTypeExtension t) - cntB = boxBuilder cnt +instance IsBoxContent (Box brand cnt) where + boxBuilder b@(Box cnt nested) = sB <> tB <> sExtB <> tExtB <> cntB <> nestedB + where s = boxSize b + t = toBoxType b cnt + 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) - where sPayload = boxSize (BoxSize undefined) - + boxSize t - + boxSize cnt - + boxSize (BoxTypeExtension t) - + boxSize nested - t = toBoxType' b + boxSize b@(Box cnt nested) = sPayload + boxSize (BoxSizeExtension sPayload) + where sPayload = + boxSize (BoxSize undefined) + boxSize t + boxSize cnt + + boxSize (BoxTypeExtension t) + + boxSize nested + t = toBoxType b cnt -- | A heterogenous collection of boxes. -data Boxes (boxTypes :: [k]) where - Nested :: Boxes '[] - (:.) :: Boxes ts -> Box' t -> Boxes (t ': ts) +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) -infixl 2 :. +infixr 1 :<> +infixr 2 :. +infixr 2 :| +infixr 3 $: -instance IsBoxContent (Boxes bs) where - boxSize Nested = 0 - boxSize (bs :. b) = boxSize bs + boxSize b - boxBuilder Nested = mempty - boxBuilder (bs :. b) = boxBuilder bs <> boxBuilder b +-- | Apply a function to a 'Boxes' collection containing only a single 'Box'. +($:) :: (Boxes brand '[l] -> r) -> Box brand l -> r +($:) f = f . singletonBox +-- | Create a 'Boxes' collection with a single 'Box'. +singletonBox :: Box brand l -> Boxes brand '[l] +singletonBox b = b :. NoBoxes + + +instance IsBoxContent (Boxes brand bs) where + boxSize NoBoxes = 0 + boxSize (l :. r) = boxSize l + boxSize r + boxSize (l :| r) = boxSize l + boxSize r + boxSize (l :<> r) = boxSize l + boxSize r + boxBuilder NoBoxes = mempty + boxBuilder (l :. r) = boxBuilder l <> boxBuilder r + boxBuilder (l :| r) = boxBuilder l <> boxBuilder r + boxBuilder (l :<> r) = boxBuilder l <> boxBuilder r + -- | A box that contains no nested boxes. -closedBox :: (IsBoxType' t, ValidBoxes t '[]) => BoxContent t -> Box' t -closedBox c = Box' c Nested +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, ValidBoxes t ts, BoxContent t ~ ()) => Boxes ts -> Box' t -containerBox = Box' () - --- | A complete media file, consisting of top-level boxes. -mediaFile :: Boxes ts -> Builder -mediaFile = boxBuilder +containerBox :: (IsBoxType t,IsBrandConform brand ('Just t) ts,BoxContent t ~ ()) + => Boxes brand ts -> Box brand t +containerBox = Box () -- * Box Size and Type - -- | The size of the box. If the size is limited to a (fixed) value, it can be -- provided as a 'Word64' which will be represented as either a 32bit compact -- size or as 64 bit /largesize/. If 'UnlimitedSize' is used, the box extends to @@ -215,90 +211,7 @@ (take (16 * 4) str) ++ repeat (word8 0)) --- * Type-safe box composition - - --- * Type level consistency checks - --- | A type-level check that uses 'BoxRules' to check that the contained boxes --- are standard conform. -type ValidBoxes t ts = - ( AllAllowedIn t ts ~ 'True - , HasAllRequiredBoxes t (RequiredNestedBoxes t) ts ~ 'True ) - --- | A type function to check that all nested boxes are allowed in the --- container. -type family AllAllowedIn (container :: k) (boxes :: [k]) :: Bool - where - AllAllowedIn c '[] = 'True - AllAllowedIn c (t ': ts) = - If (CheckAllowedIn c t (RestrictedTo t)) - (AllAllowedIn c ts) - (TypeError (NotAllowedMsg c t)) - -type family CheckAllowedIn (c :: k) (t :: k) (a :: Maybe [k]) :: Bool where - CheckAllowedIn c t 'Nothing = 'True - CheckAllowedIn c t ('Just rs) = Find c rs - - --- | The custom (type-) error message for 'AllAllowedIn'. -type NotAllowedMsg c t = - 'Text "Boxes of type: " - ':<>: 'ShowType c - ':<>: 'Text " may not contain boxes of type " - ':<>: 'ShowType t - ':$$: 'Text "Valid containers for " - ':<>: 'ShowType t - ':<>: 'Text " boxes are: " - ':$$: 'ShowType (RestrictedTo t) - ':$$: 'ShowType t - ':<>: If (IsTopLevelBox c) - ('Text " boxes may appear top-level in a file.") - ('Text " boxes must be nested.") - - --- | Check that all required boxes have been nested. -type family HasAllRequiredBoxes (c :: k) (req :: [k]) (nested :: [k]) :: Bool - where - HasAllRequiredBoxes c '[] nested = 'True - HasAllRequiredBoxes c (r ': restReq) nested = - If (Find r nested) - (HasAllRequiredBoxes c restReq nested) - (TypeError (MissingRequired c r nested)) - -type IsSubSet base sub = Intersection base sub == sub - --- | The custom (type-) error message for 'HasAllRequiredBoxes. -type MissingRequired c r nested = - 'Text "Boxes of type: " - ':<>: 'ShowType c - ':<>: 'Text " require these nested boxes: " - ':<>: 'ShowType (RequiredNestedBoxes c) - ':$$: 'Text "but only these box types were nested: " - ':<>: 'ShowType nested - ':$$: 'Text "e.g. this type is missing: " - ':<>: 'ShowType r - --- | Check that all boxes may appear top-level. -type family CheckAllTopLevelOk (ts :: [k]) :: Bool where - CheckAllTopLevelOk '[] = 'True - CheckAllTopLevelOk (t ': rest) = CheckTopLevelOk t && CheckAllTopLevelOk rest - --- | Check that the box may appear top-level. -type family CheckTopLevelOk (t :: k) :: Bool where - CheckTopLevelOk t = IsTopLevelBox t || TypeError (NotTopLevenError t) - - --- | The custom (type-) error message indicating that a box may not appear --- top-level. -type NotTopLevenError c = - 'Text "Boxes of type " - ':<>: 'ShowType c - ':<>: 'Text " MUST be nested inside boxes of these types: " - ':$$: 'ShowType (RestrictedTo c) - -- * 'IsBoxContent' instances - -- | An empty box content can by represented by @()@ (i.e. /unit/). instance IsBoxContent () where boxSize _ = 0 @@ -307,4 +220,13 @@ -- | Trivial instance for 'ByteString' instance IsBoxContent B.ByteString where boxSize = fromIntegral . B.length - boxBuilder = byteString + boxBuilder = byteString-- -- | A list, a maybe, and every other 'Foldable' of contents is a content. + -- instance (Foldable f, IsBoxContent t) => IsBoxContent (f t) where + -- boxSize = foldr' (\e acc -> acc + boxSize e) 0 + -- boxBuilder = foldMap boxBuilder + +-- | This 'Text' instance writes a null terminated UTF-8 string. +instance IsBoxContent T.Text where + 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 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,12 +4,14 @@ where import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.Default import Data.Int import Data.Maybe import Text.Printf import Data.Singletons import Data.Singletons.Prelude.List import qualified Data.Vector.Sized as Vec +import qualified Data.Text as T -- * Scalar box fields @@ -59,8 +61,14 @@ -- smart constructors, e.g. 'u8','i8','u16','i16','u32','i32','u64','i64' or the -- 'Num' instance, whereas the constructors might give a bit more safety. newtype Scalar scalartype (label :: k) = - Scalar scalartype deriving (Show, Read, Ord, Eq, Num) + Scalar {fromScalar :: scalartype} + deriving (Show, Read, Ord, Eq, Num, Default) +-- | Relabel a scalar value, e.g. convert a @Scalar U32 "foo"@ to a @Scalar U32 +-- "bar"@. +relabelScalar :: Scalar t l -> Scalar t l' +relabelScalar (Scalar x) = (Scalar x) + instance IsBoxContent (Scalar Word8 label) where boxSize _ = 1 boxBuilder (Scalar v) = word8 v @@ -153,7 +161,11 @@ -- 'u8Arr','i8Arr','u16Arr','i16Arr','u32Arr','i32Arr','u64Arr','i64Arr' . newtype ScalarArray (label :: k) (len :: Nat) o where ScalarArray :: Vec.Vector n o -> ScalarArray label n o + deriving (Show,Eq) +instance (Default o,KnownNat (len :: Nat)) => Default (ScalarArray label len o) where + def = ScalarArray $ Vec.replicate def + instance (Num o,IsBoxContent (Scalar o label),KnownNat (len :: Nat)) => IsBoxContent (ScalarArray label len o) where boxSize (ScalarArray vec) = fromIntegral (Vec.length vec) * boxSize (Scalar 0 :: Scalar o label) @@ -182,7 +194,8 @@ -- * Constant fields -- | Wrapper around a field, e.g. a 'Scalar' or 'ScalarArray', with a type level --- value. The wrapped content must implement 'FromTypeLit'. +-- value. The wrapped content must implement 'FromTypeLit'. To get the value of +-- a 'Constant' use 'fromTypeLit'. data Constant o v where Constant :: Constant o v @@ -190,6 +203,9 @@ boxSize = boxSize . fromTypeLit boxBuilder = boxBuilder . fromTypeLit +instance Default (Constant o v) where + def = Constant + -- * Template Fields -- | Fields with default values that can be overriden with custom value. Like @@ -200,10 +216,17 @@ Default :: Template o v Custom :: o -> Template o v +instance Default (Template o v) where + def = Default + +-- | Get a value from a 'Template'. +templateValue :: FromTypeLit o v => Template o v -> o +templateValue d@Default = fromTypeLit d +templateValue (Custom v) = v + instance (IsBoxContent o,FromTypeLit o v) => IsBoxContent (Template o v) where - boxSize = boxSize . fromTypeLit - boxBuilder d@Default = boxBuilder $ fromTypeLit d - boxBuilder (Custom o) = boxBuilder o + boxSize = boxSize . templateValue + boxBuilder = boxBuilder . templateValue -- * Conversion from type-level numbers and lists to values @@ -220,20 +243,19 @@ vs' = fromIntegral <$> vs in ScalarArray (fromJust (Vec.fromList vs')) +instance KnownSymbol str => FromTypeLit T.Text (str :: Symbol) where + fromTypeLit = T.pack . symbolVal + -- * Box concatenation -- | Box content composition -data Extend a b = - Extend a - b +data a :+ b = a :+ b --- | An operator for 'Extend'. -type a :+ b = Extend a b +infixr 3 :+ --- | An operator for 'Extend'. -(<+>) :: a -> b -> Extend a b -(<+>) = Extend +instance (IsBoxContent p,IsBoxContent c) => IsBoxContent (p :+ c) where + boxSize (p :+ c) = boxSize p + boxSize c + boxBuilder (p :+ c) = boxBuilder p <> boxBuilder c -instance (IsBoxContent p,IsBoxContent c) => IsBoxContent (Extend p c) where - boxSize (Extend p c) = boxSize p + boxSize c - boxBuilder (Extend p c) = boxBuilder p <> boxBuilder c +instance (Default a, Default b) => Default (a :+ b) where + def = def :+ def diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Brand.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Brand.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Brand.hs @@ -0,0 +1,217 @@ +-- | 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/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,16 +3,14 @@ import Data.ByteString.IsoBaseFileFormat.Boxes.Box -- | File Type Box - -instance BoxRules FileType - -instance IsBoxType' FileType where +instance IsBoxType FileType where type BoxContent FileType = FileType - toBoxType' _ = StdType "ftyp" + toBoxType _ _ = StdType "ftyp" -- | Create a 'FileTypeBox' from a major brand, a minor version and a list of -- compatible brands -fileTypeBox :: FileType -> Box' FileType +fileTypeBox :: (ValidBox b FileType) + => FileType -> Box b FileType fileTypeBox = closedBox -- | Contents of a 'ftyp' box are some 'FourCc' /brands/ and a version. @@ -22,7 +20,6 @@ ,compatibleBrands :: [FourCc]} instance IsBoxContent FileType where - boxSize (FileType maj _ver comps) = - boxSize maj + 4 + sum (boxSize <$> comps) + boxSize (FileType maj _ver comps) = boxSize maj + 4 + sum (boxSize <$> comps) boxBuilder (FileType maj ver comps) = boxBuilder maj <> word32BE ver <> mconcat (boxBuilder <$> comps) 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,6 +1,7 @@ -- | Full Boxes module Data.ByteString.IsoBaseFileFormat.Boxes.FullBox - (FullBox(), fullBox, closedFullBox, BoxVersion, BoxFlags(..), Versioned(..)) where + (FullBox(..), fullBox, closedFullBox, BoxVersion, BoxFlags(..)) + where import Data.ByteString.IsoBaseFileFormat.Boxes.Box import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields @@ -19,30 +20,18 @@ -- | Create a 'FullBox' from a 'BoxVersion' and 'BoxFlags' fullBox - :: (IsBoxType' t,ValidBoxes t ts,BoxContent t ~ FullBox version c) - => BoxVersion version -> BoxFlags 24 -> c -> Boxes ts -> Box' t -fullBox version fs cnt = Box' (FullBox version fs cnt) + :: (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) -- | Create a 'FullBox' from a 'BoxVersion' and 'BoxFlags' without nested boxes. closedFullBox - :: (IsBoxType' t,ValidBoxes t '[],BoxContent t ~ FullBox version c) - => BoxVersion version -> BoxFlags 24 -> c -> Box' t + :: (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) -- | The box version (in a 'FullBox') is a single byte type BoxVersion v = Template (U8 "fullbox-version") v - --- | Two alternative representations based on a /version/ index. --- Use this for box content that can be either 32 or 64 bit. -data Versioned v0 v1 (version :: Nat) where - V0 :: IsBoxContent v0 => v0 -> Versioned v0 v1 0 - V1 :: IsBoxContent v1 => v1 -> Versioned v0 v1 1 - -instance IsBoxContent (Versioned v0 v1 version) where - boxSize (V0 c) = boxSize c - boxSize (V1 c) = boxSize c - boxBuilder (V0 c) = boxBuilder c - boxBuilder (V1 c) = boxBuilder c -- | In addition to a 'BoxVersion' there can be 24 bits for custom flags etc in -- a 'FullBox'. diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Handler.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Handler.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Handler.hs @@ -0,0 +1,48 @@ +-- | A 'Handler' box describes how a track is presentation and by which sensory +-- process it is perceived, e.g. audio, video, text, see 'HandlerType' +module Data.ByteString.IsoBaseFileFormat.Boxes.Handler where + +import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields +import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox +import Data.Default +import qualified Data.Text as T + +-- | Handler box fields. A handler box may also contain a null terminated +-- description text in UTF-8. +newtype Handler where + Handler :: Constant (U32 "pre_defined") 0 + :+ HandlerType + :+ Constant (U32Arr "reserved" 3) '[0,0,0] + :+ Template T.Text "" + -> Handler + deriving (IsBoxContent, Default) + +-- | A 'Handler' can be exactly one of these. +data HandlerType = + VideoTrack + | AudioTrack + | HintTrack + | TimedMetadataTrack + | AuxilliaryVideoTrack + +-- | Create a 'MediaDataBox' from a strict 'ByteString' +handler + :: (ValidBox brand Handler) + => Handler -> Box brand Handler +handler = closedFullBox Default 0 + +instance IsBoxType Handler where + type BoxContent Handler = FullBox 0 Handler + toBoxType _ _ = StdType "hdlr" + +instance Default HandlerType where + def = AudioTrack + +instance IsBoxContent HandlerType where + boxSize _ = 4 + boxBuilder VideoTrack = boxBuilder (FourCc ('v','i','d','e')) + boxBuilder AudioTrack = boxBuilder (FourCc ('s','o','u','n')) + boxBuilder HintTrack = boxBuilder (FourCc ('h','i','n','t')) + boxBuilder TimedMetadataTrack = boxBuilder (FourCc ('m','e','t','a')) + boxBuilder AuxilliaryVideoTrack = boxBuilder (FourCc ('a','u','x','v')) diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Language.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Language.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Language.hs @@ -0,0 +1,40 @@ +-- | Boxfield indicating an ISO 639-2 alpha-3 language code. +module Data.ByteString.IsoBaseFileFormat.Boxes.Language (Language, mkLanguage) where + +import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.Default +import Data.String + +-- | A Boxfield contains an ISO 639-2-T alpha-3 language code, which is encoded +-- as a single bit followed by three 5 bit words, each representing the +-- lower-case character from the language code subtracted by 0x60. +-- If available, the code for /terminoligy/ purposes should be used (T-code). +data Language = Language Word16 + +-- | Create a 'Language', throw a runtime error when bad characters were given. +-- The characters must be in @a - z@ (lower-case!), there must be exactly three +-- characters. +mkLanguage :: String -> Language +mkLanguage [c0,c1,c2] | + (c0 > toEnum 0x60 && c0 < toEnum 0x7b && + c1 > toEnum 0x60 && c1 < toEnum 0x7b && + c2 > toEnum 0x60 && c2 < toEnum 0x7b) = + let + s :: Char -> Word16 + s c = fromIntegral (fromEnum c) - 0x60 + in Language (shiftL (s c0) 10 .|. shiftL (s c1) 5 .|. s c2) + +mkLanguage other = + error $ + "Invalid ISO 639-2 language code: " ++ show other ++ + ". The code must consist of three lower-case letters between 'a' .. 'z'." + +instance IsString Language where + fromString = mkLanguage + +instance Default Language where + def = mkLanguage "deu" + +instance IsBoxContent Language where + boxSize _ = 2 + boxBuilder (Language c) = word16BE c diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Media.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Media.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Media.hs @@ -0,0 +1,15 @@ +-- | Track specific media information container box. +module Data.ByteString.IsoBaseFileFormat.Boxes.Media where + +import Data.ByteString.IsoBaseFileFormat.Boxes.Box + +-- | Media data box +data Media + +instance IsBoxType Media where + toBoxType _ _ = StdType "mdia" + +-- | Create a 'MediaDataBox' from a strict 'ByteString' +media :: ValidContainerBox brand Media ts + => Boxes brand ts -> Box brand Media +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 @@ -1,18 +1,17 @@ +-- | Media data box module Data.ByteString.IsoBaseFileFormat.Boxes.MediaData where import Data.ByteString.IsoBaseFileFormat.Boxes.Box import qualified Data.ByteString as B --- | Media data box +-- | Media data box phantom type data MediaData -instance BoxRules MediaData - -instance IsBoxType' MediaData where +instance IsBoxType MediaData where -- | Contents of a 'mdat' box are just bytes from a strict 'ByteString' type BoxContent MediaData = B.ByteString - toBoxType' _ = StdType "mdat" + toBoxType _ _ = StdType "mdat" -- | Create a 'MediaDataBox' from a strict 'ByteString' -mediaDataBox :: B.ByteString -> Box' MediaData -mediaDataBox = closedBox +mediaData :: ValidBox b MediaData => B.ByteString -> Box b MediaData +mediaData = closedBox diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaHeader.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaHeader.hs @@ -0,0 +1,29 @@ +-- | Media-independent properties of a tracks media content. +module Data.ByteString.IsoBaseFileFormat.Boxes.MediaHeader where + +import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields +import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox +import Data.ByteString.IsoBaseFileFormat.Boxes.Language +import Data.ByteString.IsoBaseFileFormat.Boxes.Time + +-- | Media header data box. +data MediaHeader (v :: Nat) where + MediaHeader + :: KnownNat v + => Timing v :+ Language :+ Constant (I16 "pre_defined") 0 + -> MediaHeader v + +-- | Create a 'MediaHeader' box. +mediaHeader + :: (KnownNat v, ValidBox brand (MediaHeader v)) + => MediaHeader v -> Box brand (MediaHeader v) +mediaHeader = closedFullBox Default 0 + +instance (KnownNat v) => IsBoxType (MediaHeader v) where + type BoxContent (MediaHeader v) = FullBox v (MediaHeader v) + toBoxType _ _ = StdType "mdhd" + +instance IsBoxContent (MediaHeader v) where + boxSize (MediaHeader c) = boxSize c + boxBuilder (MediaHeader c) = boxBuilder c diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaInformation.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaInformation.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaInformation.hs @@ -0,0 +1,17 @@ +-- | Media information container for all boxes declaring the specific +-- technicalities of the media data associated with a 'Track'. +module Data.ByteString.IsoBaseFileFormat.Boxes.MediaInformation where + +import Data.ByteString.IsoBaseFileFormat.Boxes.Box + +-- | Media information box phantom type. +data MediaInformation + +-- | Create a 'MediaInformation' from a strict 'ByteString' +mediaInformation + :: ValidContainerBox brand MediaInformation ts + => Boxes brand ts -> Box brand MediaInformation +mediaInformation = containerBox + +instance IsBoxType MediaInformation where + toBoxType _ _ = StdType "minf" diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Movie.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Movie.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Movie.hs @@ -0,0 +1,17 @@ +-- | Meta data for a presentation of a /movie/. +module Data.ByteString.IsoBaseFileFormat.Boxes.Movie where + +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 + +-- | 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" diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieBox.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieBox.hs deleted file mode 100644 --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieBox.hs +++ /dev/null @@ -1,156 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - --- | Meta data for a presentation of a /movie/. -module Data.ByteString.IsoBaseFileFormat.Boxes.MovieBox where - -import Data.ByteString.IsoBaseFileFormat.Boxes.Box -import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields -import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox - --- | Compose a set of boxes into a 'MovieBox' --- --- Example: --- --- > xxx :: Box' Movie --- > xxx = movieBox $ --- > Nested (movieHeaderBox (...)) --- > :. (trackBox $ --- > Nested (trackHeaderBox (TrackHeader ...)) --- > :. trackReferenceBox (TrackReference ...) --- > :. trackGroupingIndication (TrackGroupingInd ...)) --- -movieBox :: ValidBoxes (Movie version) ts - => Boxes ts -> Box' (Movie version) -movieBox = 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 (version :: Nat) - -instance IsBoxType' (Movie version) where - toBoxType' _ = StdType "moov" - -instance BoxRules (Movie version) where - type RequiredNestedBoxes (Movie version) = '[MovieHeader version] - --- * @mvhd@ Box - --- | Construct a 'MovieHeader' box. -movieHeaderBox - :: KnownNat version - => MovieHeader version -> Box' (MovieHeader version) -movieHeaderBox = closedFullBox Default 0 - --- | Movie meta data, indexed by a version. -data MovieHeader (version :: Nat) where - MovieHeader :: - KnownNat version => - Versioned MovieHeaderTimesV0 - MovieHeaderTimesV1 - version - :+ Template (I32 "rate") 0x00010000 - :+ Template (I16 "volume") 0x0100 - :+ Constant (I16 "reserved") 0 - :+ Constant (I32Arr "reserved" 2) '[0,0] - :+ Constant (I32Arr "matrix" 9) - '[65536, 0, 0, 0, 65536, 0, 0, 0, 1073741824] - :+ Template (U32Arr "pre_defined" 6) '[0,0,0,0,0,0] - :+ U32 "next_track_ID" - -> MovieHeader version - --- | Time and timing information about a movie (32bit version). -type MovieHeaderTimesV0 = MovieHeaderTimes (Scalar Word32) - --- | Time and timing information about a movie (64bit version). -type MovieHeaderTimesV1 = MovieHeaderTimes (Scalar Word64) - --- | Time and timing information about a movie. -type MovieHeaderTimes uint = - uint "creation_time" - :+ uint "modification_time" - :+ U32 "timescale" - :+ uint "duration" - -instance IsBoxContent (MovieHeader version) where - 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 BoxRules (MovieHeader version) where - type IsTopLevelBox (MovieHeader version) = 'False - type GetCardinality (MovieHeader version) any = 'ExactlyOnce - type RestrictedTo (MovieHeader version) = 'Just '[Movie version] - --- * @trak@ Box - --- | Compose a 'Track' box from the given boxes. -track :: ValidBoxes (Track version) ts - => Boxes ts -> Box' (Track version) -track = containerBox - --- | Container box for tracks. -data Track (version :: Nat) - -instance IsBoxType' (Track version) where - toBoxType' _ = StdType "trak" - -instance BoxRules (Track version) where - type IsTopLevelBox (Track version) = 'False - type GetCardinality (Track version) any = 'ExactlyOnce - type RestrictedTo (Track version) = 'Just '[Movie version] - --- * @tkhd@ Box - - --- | Create a 'TrackHeader' box. -trackHeader - :: KnownNat version => TrackHeader version -> Box' (TrackHeader version) -trackHeader = closedFullBox Default 0 - --- | Track meta data, indexed by a version. -data TrackHeader (version :: Nat) where - TrackHeader :: - Versioned TrackHeaderTimesV0 - TrackHeaderTimesV1 - version - :+ Constant (I32Arr "reserved" 2) '[0, 0] - :+ Template (I16 "layer") 0 - :+ Template (I16 "alternate_group") 0 - :+ Template (I16 "volume") 256 - :+ Constant (I16 "reserved") 0 - :+ Template (I32Arr "matrix" 9) - '[65536, 0, 0, 0, 65536, 0, 0, 0, 1073741824] - :+ I32 "width" - :+ I32 "height" - -> TrackHeader version - --- | Time and timing information about a track (32bit version). -type TrackHeaderTimesV0 = TrackHeaderTimes (Scalar Word32) - --- | Time and timing information about a track (64bit version). -type TrackHeaderTimesV1 = TrackHeaderTimes (Scalar Word64) - --- | Time and timing information about a track. -type TrackHeaderTimes uint = - uint "creation_time" - :+ uint "modification_time" - :+ U32 "track_ID" - :+ Constant (U32 "reserved") 0 - :+ uint "duration" - -instance IsBoxContent (TrackHeader version) where - 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 BoxRules (TrackHeader version) where - type IsTopLevelBox (TrackHeader version) = 'False - type GetCardinality (TrackHeader version) any = 'ExactlyOnce - type RestrictedTo (TrackHeader version) = 'Just '[Track version] diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieHeader.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieHeader.hs @@ -0,0 +1,66 @@ +-- | Meta data for a presentation of a /movie/. +module Data.ByteString.IsoBaseFileFormat.Boxes.MovieHeader where + +import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields +import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox +import Data.ByteString.IsoBaseFileFormat.Boxes.Time + +-- * @mvhd@ Box + +-- | Construct a 'MovieHeader' box. +movieHeader + :: (KnownNat version, ValidBox brand (MovieHeader version)) + => MovieHeader version -> Box brand (MovieHeader version) +movieHeader = closedFullBox Default 0 + +-- | Movie meta data, indexed by a version. +-- +-- The @rate@ field is a 16.16 fix point number, 1.0 indicates the preferred +-- normal playback rate. @volume@ is also a fix point number, albeit smaller +-- with only 8.8. A volume of 1.0 is the full (loudest) volume. @matrix@ is the +-- video image transformation matrix. The @next_track_ID@ indicates the next +-- available track id, if the track ID is (0xFFFFFFFF) then the system must +-- search through all tracks associated with this presentation and figure it +-- out, 0 is not allowed. +data MovieHeader (version :: Nat) where + MovieHeader :: + KnownNat version => + Timing version + :+ Template (I32 "rate") 0x00010000 + :+ Template (I16 "volume") 0x0100 + :+ Constant (I16 "reserved") 0 + :+ Constant (I32Arr "reserved" 2) '[0,0] + :+ Template (I32Arr "matrix" 9) + '[65536, 0, 0, 0, 65536, 0, 0, 0, 1073741824] + :+ Template (U32Arr "pre_defined" 6) '[0,0,0,0,0,0] + :+ Template (U32 "next_track_ID") 0xFFFFFFFF + -> MovieHeader version + +-- | Time and timing information about a movie (32bit version). +type MovieHeaderTimesV0 = MovieHeaderTimes (Scalar Word32) + +-- | Time and timing information about a movie (64bit version). +type MovieHeaderTimesV1 = MovieHeaderTimes (Scalar Word64) + +-- | Time and timing information about a movie. +-- +-- The creation/modification times are in seconds since midnight, Jan. 1, 1904, +-- in UTC time. Time scale declares the time coordinate system, it specifies the +-- number of time units that pass one second. The time coordinate system is used +-- by e.g. the duration field, which by the way contains the duration of the +-- longest track, if known, or simply the equivalent of 1s. +type MovieHeaderTimes uint = + uint "creation_time" + :+ uint "modification_time" + :+ TimeScale + :+ uint "duration" + + +instance IsBoxContent (MovieHeader version) where + 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) 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,11 +8,9 @@ -- | A Box with progressive download information data ProgressiveDownload -instance BoxRules ProgressiveDownload - -instance IsBoxType' ProgressiveDownload where +instance IsBoxType ProgressiveDownload where type BoxContent ProgressiveDownload = FullBox 0 ProgressiveDownloadContent - toBoxType' _ = StdType "pdin" + toBoxType _ _ = StdType "pdin" -- | Information for progressive media data download/playback encompasses the -- delay for initial playback and expected download bit rate. @@ -20,5 +18,6 @@ -- | Construct a @pdin@ box. pdinBox - :: ProgressiveDownloadContent -> Box' ProgressiveDownload + :: ValidBox brand ProgressiveDownload + => ProgressiveDownloadContent -> Box brand ProgressiveDownload pdinBox = closedFullBox Default 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,15 +6,12 @@ -- | Contents of a 'skip' box are just any number of filler bytes. newtype Skip = Skip Int -instance IsBoxType' Skip where +instance IsBoxType Skip where type BoxContent Skip = Skip - toBoxType' _ = StdType "skip" - -instance BoxRules Skip where - type RestrictedTo Skip = 'Nothing + toBoxType _ _ = StdType "skip" -- | Create a 'Skip' with a given size. -skipBox :: Skip -> Box' Skip +skipBox :: ValidBox brand Skip => Skip -> Box brand Skip skipBox = closedBox instance IsBoxContent Skip where diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/SpecificMediaHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SpecificMediaHeader.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SpecificMediaHeader.hs @@ -0,0 +1,51 @@ +-- | Media-independent properties of a tracks media content. +module Data.ByteString.IsoBaseFileFormat.Boxes.SpecificMediaHeader where + +import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields +import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox + +-- | Media header data box. The actual box type is determined by the claused +-- used to construct the record. +data SpecificMediaHeader where + VideoMediaHeader + :: Template (U16 "graphicsmode") 0 + :+ Template (U16 "reserved") 0 + -> SpecificMediaHeader + SoundMediaHeader + :: Template (I16 "balance") 0 + :+ Constant (U16Arr "opcolor" 3) '[0,0,0] + -> SpecificMediaHeader + HintMediaHeader + :: U16 "maxPDUsize" + :+ U16 "avgPDUsize" + :+ U16 "maxbitrate" + :+ U16 "avgbitrate" + :+ U32 "reserved" + -> SpecificMediaHeader + NullMediaHeader + :: SpecificMediaHeader + +-- | 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 + +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 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 () diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Time.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Time.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Time.hs @@ -0,0 +1,72 @@ +-- | Time and timing utilities. +module Data.ByteString.IsoBaseFileFormat.Boxes.Time + (referenceTime, utcToMp4, mp4CurrentTime, durationFromSeconds, + TimeScale, Timing) + where + +import Data.Time.Clock +import Data.Time.Calendar +import Data.Ratio +import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields +import Data.ByteString.IsoBaseFileFormat.Boxes.Versioned + +-- * Absolute Dates +-- | According to the standard, fields with absolute dates and times are in +-- seconds since 1904/01/01 at midnight (UTC). This is this reference time. +referenceTime :: UTCTime +referenceTime = + let startDay = fromGregorian 1904 1 1 + startTime = 0 + in UTCTime startDay startTime + +-- | Convert a 'UTCTime' to a number of seconds since 'referenceTime'. +utcToMp4 :: Num t + => UTCTime -> t +utcToMp4 u = + let picoSecondsDiff = toRational $ diffUTCTime u referenceTime + picoSecondsDiffNumerator = numerator picoSecondsDiff + picoSecondsDiffDenominator = denominator picoSecondsDiff + secondsSinceReferenceTime = + div picoSecondsDiffNumerator picoSecondsDiffDenominator + in fromIntegral secondsSinceReferenceTime + +-- | Get the current time as number of seconds since 'referenceTime' +mp4CurrentTime :: Num t + => IO t +mp4CurrentTime = utcToMp4 <$> getCurrentTime + +-- * Time-Scale and Durations +-- | Default time-scale value +-- Based on history and tradition this value is @90000@. +-- MPEG-2 TS defines a single clock for each program, running at 27MHz. The +-- timescale of MPEG-2 TS Hint Tracks should be divisable by 90000. +type TimeScale = Template (U32 "timescale") 90000 + +-- | Utility function to convert seconds (Integers) to any 'Num' using a +-- 'TimeScale', Since 'Scalar' has a 'Num' instance this can be used to generate +-- @duration@ fields. +durationFromSeconds :: Num t + => TimeScale -> Integer -> t +durationFromSeconds timeScale seconds = + let timeScaleI = fromIntegral $ fromScalar $ templateValue timeScale + in timeScaleI * fromInteger seconds + +-- | Time and timing information about a movie. +-- +-- The creation/modification times are in seconds since midnight, Jan. 1, 1904, +-- in UTC time. Time scale declares the time coordinate system, it specifies the +-- number of time units that pass one second. The time coordinate system is used +-- by e.g. the duration field, which by the way contains the duration of the +-- longest track, if known, or simply the equivalent of 1s. +type Timing (version :: Nat) = Versioned TimingV0 TimingV1 version + +type TimingV0 = TimingImpl (Scalar Word32) + +type TimingV1 = TimingImpl (Scalar Word64) + +type TimingImpl uint = + uint "creation_time" + :+ uint "modification_time" + :+ TimeScale + :+ uint "duration" diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Track.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Track.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Track.hs @@ -0,0 +1,17 @@ +-- | Meta data for a presentation of a /movie/. +module Data.ByteString.IsoBaseFileFormat.Boxes.Track where + +import Data.ByteString.IsoBaseFileFormat.Boxes.Box + +-- * @trak@ Box +-- | Compose a 'Track' box from the given boxes. +track + :: (ValidContainerBox brand Track ts) + => Boxes brand ts -> Box brand Track +track = containerBox + +-- | Container box for tracks. +data Track + +instance IsBoxType Track where + toBoxType _ _ = StdType "trak" diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackHeader.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackHeader.hs @@ -0,0 +1,51 @@ +-- | Track header box +module Data.ByteString.IsoBaseFileFormat.Boxes.TrackHeader where + +import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields +import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox +import Data.ByteString.IsoBaseFileFormat.Boxes.Versioned + +-- * @tkhd@ Box +-- | Create a 'TrackHeader' box. +trackHeader + :: (ValidBox brand (TrackHeader version), version ~ GetVersion brand) + => TrackHeader version -> Box brand (TrackHeader version) +trackHeader = closedFullBox Default 0 + +-- | Track meta data, indexed by a version. +data TrackHeader (version :: Nat) where + TrackHeader :: + Versioned TrackHeaderTimesV0 TrackHeaderTimesV1 version + :+ Constant (I32Arr "reserved" 2) '[0, 0] + :+ Template (I16 "layer") 0 + :+ Template (I16 "alternate_group") 0 + :+ Template (I16 "volume") 256 + :+ Constant (I16 "reserved") 0 + :+ Template (I32Arr "matrix" 9) + '[65536, 0, 0, 0, 65536, 0, 0, 0, 1073741824] + :+ I32 "width" + :+ I32 "height" + -> TrackHeader version + +-- | Time and timing information about a track (32bit version). +type TrackHeaderTimesV0 = TrackHeaderTimes (Scalar Word32) + +-- | Time and timing information about a track (64bit version). +type TrackHeaderTimesV1 = TrackHeaderTimes (Scalar Word64) + +-- | Time and timing information about a track. +type TrackHeaderTimes uint = + uint "creation_time" + :+ uint "modification_time" + :+ U32 "track_ID" + :+ Constant (U32 "reserved") 0 + :+ uint "duration" + +instance IsBoxContent (TrackHeader version) where + 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" diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Versioned.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Versioned.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Versioned.hs @@ -0,0 +1,22 @@ +-- | A binary version 0/1 field with seperate content for each version. +module Data.ByteString.IsoBaseFileFormat.Boxes.Versioned + (Versioned(..)) + where + +import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.Default + +-- | Two alternative representations based on a /version/ index. +-- Use this for box content that can be either 32 or 64 bit. +data Versioned v0 v1 (version :: Nat) where + V0 :: IsBoxContent v0 => v0 -> Versioned v0 v1 0 + V1 :: IsBoxContent v1 => v1 -> Versioned v0 v1 1 + +instance (version ~ 0,IsBoxContent v0,Default v0) => Default (Versioned v0 v1 (version :: Nat)) where + def = V0 def + +instance IsBoxContent (Versioned v0 v1 version) where + boxSize (V0 c) = boxSize c + boxSize (V1 c) = boxSize c + boxBuilder (V0 c) = boxBuilder c + boxBuilder (V1 c) = boxBuilder c diff --git a/src/Data/ByteString/IsoBaseFileFormat/Brands/Dash.hs b/src/Data/ByteString/IsoBaseFileFormat/Brands/Dash.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/IsoBaseFileFormat/Brands/Dash.hs @@ -0,0 +1,80 @@ +-- | 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 + +import Data.ByteString.IsoBaseFileFormat.Boxes as X +import Data.Kind (Type, Constraint) +import Control.Lens + +-- | 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 'BoxLayout' which contains the stuff needed for the 'dash' brand. +-- TODO incomplete +instance KnownNat v => IsBrand (Dash v) where + type GetVersion (Dash v) = v + 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] + +-- Missing Boxes +-- START 17:47: +-- mdia +-- mdhd +-- hdlr +-- minf +-- smhd +-- dinf +-- dref +-- ??url +-- stbl +-- stsd +-- stts +-- stsc +-- stsz +-- stco +-- soun +-- mp4a +-- esds +-- mvex +-- trex +-- For media +-- styp +-- moof +-- mfhd +-- traf +-- tfhd +-- 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} + +makeLenses ''SingleTrackInit + +-- | Convert a 'SingleTrackInit' 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)))) diff --git a/src/Data/ByteString/IsoBaseFileFormat/Builder.hs b/src/Data/ByteString/IsoBaseFileFormat/Builder.hs deleted file mode 100644 --- a/src/Data/ByteString/IsoBaseFileFormat/Builder.hs +++ /dev/null @@ -1,20 +0,0 @@ --- | This module re-exports all modules needed to build /ISOBMFF/ documents. -module Data.ByteString.IsoBaseFileFormat.Builder - (module X) - where - -import Data.ByteString.IsoBaseFileFormat.Boxes.Box as X -import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields as X -import Data.ByteString.IsoBaseFileFormat.Boxes.FileType as X -import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox as X -import Data.ByteString.IsoBaseFileFormat.Boxes.MediaData as X -import Data.ByteString.IsoBaseFileFormat.Boxes.MovieBox as X -import Data.ByteString.IsoBaseFileFormat.Boxes.ProgressiveDownloadInformation as X -import Data.ByteString.IsoBaseFileFormat.Boxes.Skip as X - -import Data.Int as X -import Data.Kind as X (Type, Constraint) -import Data.Maybe as X -import Data.Type.Bool as X -import Data.Type.Equality as X -import Text.Printf as X