-- -- Module : ContentType -- Copyright : (c) Conrad Parker 2006 -- License : BSD-style -- Maintainer : conradp@cse.unsw.edu.au -- Stability : experimental -- Portability : portable module Codec.Container.Ogg.ContentType ( ContentType (..), -- | A list of content type labels (eg. "Vorbis", "Theora") known by HOgg knownContentTypes, identify, granulerate, granuleshift, parseType, -- ContentTyped typeclass ContentTyped, contentTypeIs, contentTypeOf, contentTypeEq, demuxByContentType, -- Some guaranteed-known content-types skeleton, cmml, flac, speex, celt, theora, vorbis ) where import Data.Bits import qualified Data.ByteString.Lazy as L import Data.Char import Data.List (sort) import Data.Map (fromList) import Data.Maybe import Data.Ratio import Text.Printf import Codec.Container.Ogg.ByteFields import Codec.Container.Ogg.Granulerate import Codec.Container.Ogg.List import Codec.Container.Ogg.MessageHeaders import Codec.Container.Ogg.Timestamp import Codec.Container.Ogg.TimeScheme ------------------------------------------------------------ -- | Typeclass: ContentTyped -- class ContentTyped a where contentTypeIs :: ContentType -> a -> Bool contentTypeOf :: a -> Maybe ContentType contentTypeEq :: (ContentTyped a, ContentTyped b) => a -> b -> Bool contentTypeEq a b = case (contentTypeOf a, contentTypeOf b) of (Just ca, Just cb) -> ca == cb _ -> False -- | Group a list of ContentTyped items by their Content-Type demuxByContentType :: (ContentTyped a) => [a] -> [[a]] demuxByContentType = classify contentTypeEq ------------------------------------------------------------ -- | Data: ContentType -- data ContentType = ContentType { label :: String, mime :: [String], identifyP :: L.ByteString -> Bool, -- predictate, used by identify headers :: L.ByteString -> Int, preroll :: Int, granulerateF :: Maybe (L.ByteString -> Granulerate), -- used by granulerate granuleshiftF :: Maybe (L.ByteString -> Int), -- used by granuleshift metadata :: L.ByteString -> MessageHeaders } knownContentTypes :: [String] knownContentTypes = sort $ map label known known :: [ContentType] known = [skeleton, cmml, vorbis, theora, speex, celt, flac, oggpcm2] identify :: L.ByteString -> Maybe ContentType identify d = listToMaybe $ filter (\x -> identifyP x d) known granulerate :: ContentType -> L.ByteString -> Maybe Granulerate granulerate c d = maybe Nothing (\f -> Just (f d)) (granulerateF c) granuleshift :: ContentType -> L.ByteString -> Maybe Int granuleshift c d = maybe Nothing (\f -> Just (f d)) (granuleshiftF c) parseType :: String -> Maybe ContentType parseType s = listToMaybe $ filter (\x -> l (label x) == l s) known where l = map toLower ------------------------------------------------------------ -- Eq -- instance Eq ContentType where (==) a b = label a == label b ------------------------------------------------------------ -- Read -- instance Read ContentType where readsPrec _ = readsContentType readsContentType :: ReadS ContentType readsContentType str = [(c, rest) | (tok, rest) <- lex str, c <- matches tok] where matches = \m -> filter (sameLabel m) known sameLabel m = \x -> l (label x) == l m l = map toLower ------------------------------------------------------------ -- Show -- instance Show ContentType where show x = label x ------------------------------------------------------------ -- Skeleton -- skeleton :: ContentType skeleton = ContentType "Skeleton" -- label ["application/x-ogg-skeleton"] -- mime (L.isPrefixOf skeletonIdent) -- identify (const 0) -- headers 0 -- preroll Nothing -- granulerate Nothing -- granuleshift skeletonMetadata -- skeletonIdent = 'fishead\0' skeletonIdent :: L.ByteString skeletonIdent = L.pack [0x66, 0x69, 0x73, 0x68, 0x65, 0x61, 0x64, 0x00] -- Extract the Presentation time, Basetime from Fishead (Skeleton BOS) skeletonMetadata :: L.ByteString -> MessageHeaders skeletonMetadata d = MessageHeaders (fromList headerVals) where headerVals = [prestime, basetime] prestime = ("Presentation-Time", [show (t 12 20)]) basetime = ("Basetime", [show (t 28 36)]) -- | Read a timestamp encoded as a (le64,le64) rational, where a -- denominator of 0 is interepreted as the result being 0. t o1 o2 = case od of 0 -> Timestamp (0, 1) _ -> Timestamp (on, od) where on = le64At o1 d od = le64At o2 d ------------------------------------------------------------ -- CMML -- cmml :: ContentType cmml = ContentType "CMML" -- label ["text/x-cmml"] -- mime (L.isPrefixOf cmmlIdent) -- identify (const 3) -- headers 0 -- preroll (Just (\d -> fracRate (le64At 12 d) (le64At 20 d))) -- granulerate (Just (\d -> u8At 28 d)) -- granuleshift (const mhEmpty) -- cmmlIdent = 'CMML\0\0\0\0\' cmmlIdent :: L.ByteString cmmlIdent = L.pack [0x43, 0x4d, 0x4d, 0x4c, 0x00, 0x00, 0x00, 0x00] ------------------------------------------------------------ -- Vorbis -- vorbis :: ContentType vorbis = ContentType "Vorbis" -- label ["audio/x-vorbis"] -- mime (L.isPrefixOf vorbisIdent) -- identify (const 3) -- headers 2 -- preroll (Just (\d -> intRate (le32At 12 d))) -- granulerate Nothing -- granuleshift vorbisMetadata -- vorbisIdent = '\x01vorbis' vorbisIdent :: L.ByteString vorbisIdent = L.pack [0x01, 0x76, 0x6f, 0x72, 0x62, 0x69, 0x73] -- Extract sample rate from Vorbis BOS header vorbisMetadata :: L.ByteString -> MessageHeaders vorbisMetadata d = MessageHeaders (fromList headerVals) where headerVals = [samplerate, channels] samplerate = ("Audio-Samplerate", [printf "%d Hz" srate]) channels = ("Audio-Channels", [show c]) srate = (le32At 12 d) :: Int c = (u8At 11 d) :: Int ------------------------------------------------------------ -- Theora -- theora :: ContentType theora = ContentType "Theora" -- label ["video/x-theora"] -- mime (L.isPrefixOf theoraIdent) -- identify (const 3) -- headers 0 -- preroll (Just (\d -> fracRate (be32At 22 d) (be32At 26 d))) -- granulerate (Just theoraGranuleshift) -- granuleshift theoraMetadata -- metadata -- theoraIdent = '\x80theora' theoraIdent :: L.ByteString theoraIdent = L.pack [0x80, 0x74, 0x68, 0x65, 0x6f, 0x72, 0x61] -- Theora's granuleshift is an 8 bit field split over two bytes theoraGranuleshift :: L.ByteString -> Int theoraGranuleshift d = (h40 .|. h41) where h40 = (u8At 40 d .&. 0x03) `shiftL` 3 h41 = (u8At 41 d .&. 0xe0) `shiftR` 5 -- Extract video dimensions etc. from the Theora BOS header theoraMetadata :: L.ByteString -> MessageHeaders theoraMetadata d = MessageHeaders (fromList headerVals) where headerVals = [framerate, width, height] framerate = ("Video-Framerate", [printf "%.3f fps%s" fps tsName]) width = ("Video-Width", [show w]) height = ("Video-Height", [show h]) toDouble :: Integer -> Double -- monomorphic cast to double toDouble x = (fromIntegral x) :: Double fps = toDouble fpsN / toDouble fpsD mTS = guessTimeScheme (fpsN % fpsD) tsName = maybe "" (\x -> " (" ++ show x ++ ")") mTS fpsN = be32At 22 d fpsD = be32At 26 d w = ((be16At 10 d) * 16) :: Int h = ((be16At 12 d) * 16) :: Int ------------------------------------------------------------ -- Speex -- speex :: ContentType speex = ContentType "Speex" -- label ["audio/x-speex"] -- mime (L.isPrefixOf speexIdent) -- identify (\d -> (le32At 68 d) + 2) -- headers 3 -- preroll (Just (\d -> intRate (le32At 36 d))) -- granulerate Nothing -- granuleshift speexMetadata -- speexIdent = 'Speex ' speexIdent :: L.ByteString speexIdent = L.pack [0x53, 0x70, 0x65, 0x65, 0x78, 0x20, 0x20, 0x20] -- Extract sample rate from Speex BOS header speexMetadata :: L.ByteString -> MessageHeaders speexMetadata d = MessageHeaders (fromList headerVals) where headerVals = [samplerate, channels] samplerate = ("Audio-Samplerate", [printf "%d Hz" srate]) channels = ("Audio-Channels", [show c]) srate = (le32At 36 d) :: Int c = (le32At 48 d) :: Int ------------------------------------------------------------ -- CELT -- celt :: ContentType celt = ContentType "CELT" -- label ["audio/x-celt"] -- mime (L.isPrefixOf celtIdent) -- identify (\d -> (le32At 52 d) + 2) -- headers 3 -- preroll (Just (\d -> intRate (le32At 40 d))) -- granulerate Nothing -- granuleshift celtMetadata -- celtIdent = 'CELT ' celtIdent :: L.ByteString celtIdent = L.pack [0x43, 0x45, 0x4c, 0x54, 0x20, 0x20, 0x20, 0x20] -- Extract sample rate from Speex BOS header celtMetadata :: L.ByteString -> MessageHeaders celtMetadata d = MessageHeaders (fromList headerVals) where headerVals = [samplerate, channels] samplerate = ("Audio-Samplerate", [printf "%d Hz" srate]) channels = ("Audio-Channels", [show c]) srate = (le32At 40 d) :: Int c = (le32At 44 d) :: Int ------------------------------------------------------------ -- FLAC -- flac :: ContentType flac = ContentType "FLAC" -- label ["audio/x-flac"] -- mime (L.isPrefixOf flacIdent) -- identify (\d -> be16At 7 d) -- headers 0 -- preroll (Just flacGranulerate) -- granulerate Nothing -- granuleshift flacMetadata -- flacIdent = 0x7F:"FLAC" flacIdent :: L.ByteString flacIdent = L.pack [0x7f, 0x46, 0x4c, 0x41, 0x43, 0x01] -- Extract sample rate from FLAC BOS header flacMetadata :: L.ByteString -> MessageHeaders flacMetadata d = MessageHeaders (fromList headerVals) where headerVals = [samplerate, channels, version] samplerate = ("Audio-Samplerate", [(show srate) ++ " Hz"]) channels = ("Audio-Channels", [show c]) version = ("FLAC-Ogg-Mapping-Version", [show vMaj ++ "." ++ show vMin]) srate = flacGranulerate d c = 1 + (u8At 29 d `shiftR` 1) .&. 0x7 :: Int vMaj = u8At 5 d :: Integer vMin = u8At 6 d :: Integer flacGranulerate :: L.ByteString -> Granulerate flacGranulerate d = intRate $ h27 .|. h28 .|. h29 where h27 = (u8At 27 d) `shiftL` 12 h28 = (u8At 28 d) `shiftL` 4 h29 = (u8At 29 d .&. 0xf0) `shiftR` 4 ------------------------------------------------------------ -- OggPCM2: http://wiki.xiph.org/index.php/OggPCM2 -- oggpcm2 :: ContentType oggpcm2 = ContentType "PCM" -- label ["audio/x-ogg-pcm"] -- mime (L.isPrefixOf oggpcm2Ident) -- identify (const 3) -- headers 0 -- preroll (Just (\d -> intRate (be32At 16 d))) -- granulerate Nothing -- granuleshift oggpcm2Metadata -- oggpcm2Ident = 'PCM ' oggpcm2Ident :: L.ByteString oggpcm2Ident = L.pack [0x50, 0x43, 0x4D, 0x20, 0x20, 0x20, 0x20, 0x20] -- Extract sample rate from OggPCM2 BOS header oggpcm2Metadata :: L.ByteString -> MessageHeaders oggpcm2Metadata d = MessageHeaders (fromList headerVals) where headerVals = [samplerate, channels] samplerate = ("Audio-Samplerate", [printf "%d Hz" srate]) channels = ("Audio-Channels", [show c]) srate = (be32At 16 d) :: Int c = (u8At 21 d) :: Int