module Data.ByteString.IsoBaseFileFormat.Boxes.Box
(module Data.ByteString.IsoBaseFileFormat.Boxes.Box, module X)
where
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 GHC.TypeLits as X
import Data.String
import Data.Type.Equality
import Data.Type.List
import Data.Type.Bool
import qualified Data.ByteString as B
class (IsBoxContent (BoxContent t), BoxRules t) => IsBoxType' t where
type BoxContent t
type BoxContent t = ()
toBoxType' :: proxy t -> BoxType
class BoxRules (t :: k) where
type RestrictedTo t :: Maybe [k]
type RestrictedTo t = 'Just '[]
type IsTopLevelBox t :: Bool
type IsTopLevelBox t = 'True
type RequiredNestedBoxes t :: [k]
type RequiredNestedBoxes t = '[]
type GetCardinality t (c :: k) :: Cardinality
type GetCardinality t any = 'ExactlyOnce
data Cardinality = AtMostOnce | ExactlyOnce | OnceOrMore
class IsBoxContent a where
boxSize :: a -> BoxSize
boxBuilder :: a -> Builder
data Box' b where
Box' :: (IsBoxType' b, ValidBoxes b ts) => BoxContent b -> Boxes ts -> Box' 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
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
data Boxes (boxTypes :: [k]) where
Nested :: Boxes '[]
(:.) :: Boxes ts -> Box' t -> Boxes (t ': ts)
infixl 2 :.
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
closedBox :: (IsBoxType' t, ValidBoxes t '[]) => BoxContent t -> Box' t
closedBox c = Box' c Nested
containerBox :: (IsBoxType' t, ValidBoxes t ts, BoxContent t ~ ()) => Boxes ts -> Box' t
containerBox = Box' ()
mediaFile :: Boxes ts -> Builder
mediaFile = boxBuilder
data BoxSize
= UnlimitedSize
| BoxSize Word64
deriving (Show,Eq)
instance IsBoxContent BoxSize where
boxSize _ = BoxSize 4
boxBuilder UnlimitedSize = word32BE 0
boxBuilder (BoxSize n) =
word32BE $
if n < (4294967296 :: Word64)
then fromIntegral n
else 1
instance Num BoxSize where
(+) UnlimitedSize _ = UnlimitedSize
(+) _ UnlimitedSize = UnlimitedSize
(+) (BoxSize l) (BoxSize r) = BoxSize (l + r)
() UnlimitedSize _ = UnlimitedSize
() _ UnlimitedSize = UnlimitedSize
() (BoxSize l) (BoxSize r) = BoxSize (l r)
(*) UnlimitedSize _ = UnlimitedSize
(*) _ UnlimitedSize = UnlimitedSize
(*) (BoxSize l) (BoxSize r) = BoxSize (l * r)
abs UnlimitedSize = UnlimitedSize
abs (BoxSize n) = BoxSize (abs n)
signum UnlimitedSize = UnlimitedSize
signum (BoxSize n) = BoxSize (signum n)
fromInteger n = BoxSize $ fromInteger n
data BoxSizeExtension =
BoxSizeExtension BoxSize
instance IsBoxContent BoxSizeExtension where
boxBuilder (BoxSizeExtension UnlimitedSize) = mempty
boxBuilder (BoxSizeExtension (BoxSize n)) =
if n < 4294967296
then mempty
else word64BE n
boxSize (BoxSizeExtension UnlimitedSize) = 0
boxSize (BoxSizeExtension (BoxSize n)) =
BoxSize $
if n < 4294967296
then 0
else 8
data BoxType
=
StdType FourCc
|
CustomBoxType String
deriving (Show,Eq)
newtype FourCc =
FourCc (Char,Char,Char,Char)
deriving (Show,Eq)
instance IsString FourCc where
fromString str
| length str == 4 =
let [a,b,c,d] = str
in FourCc (a,b,c,d)
| otherwise =
error ("cannot make a 'FourCc' of a String which isn't exactly 4 bytes long: " ++
show str ++ " has a length of " ++ show (length str))
instance IsBoxContent FourCc where
boxSize _ = 4
boxBuilder (FourCc (a,b,c,d)) = putW a <> putW b <> putW c <> putW d
where putW = word8 . fromIntegral . fromEnum
instance IsBoxContent BoxType where
boxSize _ = boxSize (FourCc undefined)
boxBuilder t =
case t of
StdType x -> boxBuilder x
CustomBoxType _ -> boxBuilder (FourCc ('u','u','i','d'))
data BoxTypeExtension =
BoxTypeExtension BoxType
instance IsBoxContent BoxTypeExtension where
boxSize (BoxTypeExtension (StdType _)) = 0
boxSize (BoxTypeExtension (CustomBoxType _)) = 16 * 4
boxBuilder (BoxTypeExtension (StdType _)) = mempty
boxBuilder (BoxTypeExtension (CustomBoxType str)) =
mconcat (map (word8 . fromIntegral . fromEnum)
(take (16 * 4) str) ++
repeat (word8 0))
type ValidBoxes t ts =
( AllAllowedIn t ts ~ 'True
, HasAllRequiredBoxes t (RequiredNestedBoxes t) ts ~ 'True )
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
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.")
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
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
type family CheckAllTopLevelOk (ts :: [k]) :: Bool where
CheckAllTopLevelOk '[] = 'True
CheckAllTopLevelOk (t ': rest) = CheckTopLevelOk t && CheckAllTopLevelOk rest
type family CheckTopLevelOk (t :: k) :: Bool where
CheckTopLevelOk t = IsTopLevelBox t || TypeError (NotTopLevenError t)
type NotTopLevenError c =
'Text "Boxes of type "
':<>: 'ShowType c
':<>: 'Text " MUST be nested inside boxes of these types: "
':$$: 'ShowType (RestrictedTo c)
instance IsBoxContent () where
boxSize _ = 0
boxBuilder _ = mempty
instance IsBoxContent B.ByteString where
boxSize = fromIntegral . B.length
boxBuilder = byteString