module Codec.Container.Ogg.ContentType (
ContentType (..),
knownContentTypes,
identify,
granulerate,
granuleshift,
parseType,
ContentTyped,
contentTypeIs,
contentTypeOf,
contentTypeEq,
demuxByContentType,
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
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
demuxByContentType :: (ContentTyped a) => [a] -> [[a]]
demuxByContentType = classify contentTypeEq
data ContentType =
ContentType {
label :: String,
mime :: [String],
identifyP :: L.ByteString -> Bool,
headers :: L.ByteString -> Int,
preroll :: Int,
granulerateF :: Maybe (L.ByteString -> Granulerate),
granuleshiftF :: Maybe (L.ByteString -> Int),
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
instance Eq ContentType where
(==) a b = label a == label b
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
instance Show ContentType where
show x = label x
skeleton :: ContentType
skeleton = ContentType
"Skeleton"
["application/x-ogg-skeleton"]
(L.isPrefixOf skeletonIdent)
(const 0)
0
Nothing
Nothing
skeletonMetadata
skeletonIdent :: L.ByteString
skeletonIdent = L.pack [0x66, 0x69, 0x73, 0x68, 0x65, 0x61, 0x64, 0x00]
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)])
t o1 o2 = case od of
0 -> Timestamp (0, 1)
_ -> Timestamp (on, od)
where
on = le64At o1 d
od = le64At o2 d
cmml :: ContentType
cmml = ContentType
"CMML"
["text/x-cmml"]
(L.isPrefixOf cmmlIdent)
(const 3)
0
(Just (\d -> fracRate (le64At 12 d) (le64At 20 d)))
(Just (\d -> u8At 28 d))
(const mhEmpty)
cmmlIdent :: L.ByteString
cmmlIdent = L.pack [0x43, 0x4d, 0x4d, 0x4c, 0x00, 0x00, 0x00, 0x00]
vorbis :: ContentType
vorbis = ContentType
"Vorbis"
["audio/x-vorbis"]
(L.isPrefixOf vorbisIdent)
(const 3)
2
(Just (\d -> intRate (le32At 12 d)))
Nothing
vorbisMetadata
vorbisIdent :: L.ByteString
vorbisIdent = L.pack [0x01, 0x76, 0x6f, 0x72, 0x62, 0x69, 0x73]
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 :: ContentType
theora = ContentType
"Theora"
["video/x-theora"]
(L.isPrefixOf theoraIdent)
(const 3)
0
(Just (\d -> fracRate (be32At 22 d) (be32At 26 d)))
(Just theoraGranuleshift)
theoraMetadata
theoraIdent :: L.ByteString
theoraIdent = L.pack [0x80, 0x74, 0x68, 0x65, 0x6f, 0x72, 0x61]
theoraGranuleshift :: L.ByteString -> Int
theoraGranuleshift d = (h40 .|. h41)
where h40 = (u8At 40 d .&. 0x03) `shiftL` 3
h41 = (u8At 41 d .&. 0xe0) `shiftR` 5
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
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 :: ContentType
speex = ContentType
"Speex"
["audio/x-speex"]
(L.isPrefixOf speexIdent)
(\d -> (le32At 68 d) + 2)
3
(Just (\d -> intRate (le32At 36 d)))
Nothing
speexMetadata
speexIdent :: L.ByteString
speexIdent = L.pack [0x53, 0x70, 0x65, 0x65, 0x78, 0x20, 0x20, 0x20]
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 :: ContentType
celt = ContentType
"CELT"
["audio/x-celt"]
(L.isPrefixOf celtIdent)
(\d -> (le32At 52 d) + 2)
3
(Just (\d -> intRate (le32At 40 d)))
Nothing
celtMetadata
celtIdent :: L.ByteString
celtIdent = L.pack [0x43, 0x45, 0x4c, 0x54, 0x20, 0x20, 0x20, 0x20]
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 :: ContentType
flac = ContentType
"FLAC"
["audio/x-flac"]
(L.isPrefixOf flacIdent)
(\d -> be16At 7 d)
0
(Just flacGranulerate)
Nothing
flacMetadata
flacIdent :: L.ByteString
flacIdent = L.pack [0x7f, 0x46, 0x4c, 0x41, 0x43, 0x01]
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 :: ContentType
oggpcm2 = ContentType
"PCM"
["audio/x-ogg-pcm"]
(L.isPrefixOf oggpcm2Ident)
(const 3)
0
(Just (\d -> intRate (be32At 16 d)))
Nothing
oggpcm2Metadata
oggpcm2Ident :: L.ByteString
oggpcm2Ident = L.pack [0x50, 0x43, 0x4D, 0x20, 0x20, 0x20, 0x20, 0x20]
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