module Codec.Container.Ogg.Chop (
chop,
chopWithSkel
) where
import Control.Monad.Identity
import Control.Monad.State
import qualified Data.ByteString.Lazy as L
import Data.List
import Data.Maybe
import Codec.Container.Ogg.Chain
import Codec.Container.Ogg.ContentType
import Codec.Container.Ogg.Granulepos
import Codec.Container.Ogg.List
import Codec.Container.Ogg.Page
import Codec.Container.Ogg.Packet
import Codec.Container.Ogg.Serial
import Codec.Container.Ogg.Skeleton
import Codec.Container.Ogg.Timestamp
import Codec.Container.Ogg.Track
type ChopState = [ChopTrackState]
data ChopTrackState =
ChopTrackState {
ctsTrack :: OggTrack,
ctsBOS :: [OggPage],
ctsHdrs :: [OggPage],
headersRemaining :: Int,
ctsStartgranule :: Granulepos,
prevK :: Integer,
pageAccum :: [OggPage],
ended :: Bool
}
emptyChopState :: ChopState
emptyChopState = []
newChopTrackState :: OggTrack -> ChopTrackState
newChopTrackState t = ChopTrackState t [] [] 0 (Granulepos Nothing) 0 [] False
type Chop a = (StateT ChopState Identity) a
runChop :: ChopState -> Chop a -> (a, ChopState)
runChop st x = runIdentity (runStateT x st)
chop :: Maybe Timestamp -> Maybe Timestamp -> OggChain -> IO OggChain
chop start end chain =
return $ fst $ runChop emptyChopState (chopTop start end chain)
chopWithSkel :: Maybe Timestamp -> Maybe Timestamp -> OggChain -> IO OggChain
chopWithSkel start end chain = case hasSkel of
True -> do
return $ fst $ runChop emptyChopState (chopTop start end chain)
False -> do
s <- genSerial
let skelTrack = (newTrack s){trackType = Just skeleton}
st = [newChopTrackState skelTrack]
return $ fst $ runChop st (chopTop start end chain)
where
hasSkel = any (contentTypeIs skeleton) (chainTracks chain)
chopTop :: Maybe Timestamp -> Maybe Timestamp -> OggChain -> Chop OggChain
chopTop mStart mEnd (OggChain tracks pages _) = do
pages' <- chopTop' mStart mEnd pages
let packets' = pagesToPackets pages'
return $ OggChain tracks pages' packets'
chopTop' :: Maybe Timestamp -> Maybe Timestamp -> [OggPage] -> Chop [OggPage]
chopTop' _ _ [] = return []
chopTop' Nothing Nothing gs = return gs
chopTop' Nothing mEnd@(Just _) gs = chopTo mEnd gs
chopTop' (Just start) mEnd (g:gs)
| pageBOS g = do
pushBOS g
addHeaders g
subHeaders g
chopTop' (Just start) mEnd gs
| otherwise = do
p <- doneHeaders
case p of
False -> do
subHeaders g
pushHdr g
chopTop' (Just start) mEnd gs
True -> chopRaw (Just start) mEnd (g:gs)
chopRaw :: Maybe Timestamp -> Maybe Timestamp -> [OggPage] -> Chop [OggPage]
chopRaw _ _ [] = return []
chopRaw Nothing Nothing gs = return gs
chopRaw Nothing mEnd@(Just _) gs = chopTo mEnd gs
chopRaw (Just start) mEnd (g:gs) = case (timestampOf g) of
Nothing -> do
chopAccum g
return g >> (chopRaw (Just start) mEnd gs)
(Just gTime) -> do
p <- changedK g
case p of
False -> do
chopAccum g
True -> do
pruneAccum g
setK g
chopAccum g
case (compare start gTime) of
LT -> do
ctrl <- chopCtrl (Just start)
cs <- chopRaw Nothing mEnd gs
return $ ctrl ++ cs
_ -> do
chopRaw (Just start) mEnd gs
chopCtrl :: Maybe Timestamp -> Chop [OggPage]
chopCtrl mStart = do
l <- get
let skelTrack = ctsTrack $ head l
haveSkel = (trackType skelTrack == Just skeleton)
presentation = fromMaybe zeroTimestamp mStart
base = zeroTimestamp
fh = fisheadToPage skelTrack $ OggFishead presentation base
fbs = Data.Maybe.mapMaybe (chopFisbone skelTrack) (tail l)
sEOS = (uncutPage L.empty skelTrack sEOSgp){pageEOS = True}
sEOSgp = Granulepos (Just 0)
boss <- popBOSs
hdrs <- popHdrs
as <- getAccum
case haveSkel of
True -> return $ [fh] ++ boss ++ fbs ++ hdrs ++ [sEOS] ++ as
False -> return $ boss ++ hdrs ++ as
chopFisbone :: OggTrack -> ChopTrackState -> Maybe OggPage
chopFisbone skelTrack cts = do
fb <- trackToFisbone $ ctsTrack cts
let fb' = fb{fisboneStartgranule = gpUnpack $ ctsStartgranule cts}
return $ fisboneToPage skelTrack fb'
chopTo :: Maybe Timestamp -> [OggPage] -> Chop [OggPage]
chopTo _ [] = return []
chopTo mEnd (g:gs)
| before mEnd g = do
cs <- chopTo mEnd gs
return $ g : cs
| otherwise = chopEnd mEnd (g:gs)
chopEnd :: Maybe Timestamp -> [OggPage] -> Chop [OggPage]
chopEnd _ [] = return []
chopEnd mEnd (g:gs) = do
ts <- findState g
case (ended ts) of
True -> do
isEnded <- allEnded
case isEnded of
True -> return []
False -> chopEnd mEnd gs
False -> do
replState ts{ended = True}
cs <- chopEnd mEnd gs
return $ g{pageEOS = True} : cs
findState :: OggPage -> Chop ChopTrackState
findState g = do
l <- get
let t = pageTrack g
mSt = find (\x -> ctsTrack x == t) l
return $ fromMaybe (newChopTrackState t) mSt
replState :: ChopTrackState -> Chop ()
replState st = do
l <- get
let l' = foldr (\x -> if (sameTrack x) then (:) st else (:) x) [] l
put l'
where
sameTrack x = (ctsTrack x == ctsTrack st)
pushBOS :: OggPage -> Chop ()
pushBOS g = do
l <- get
let st = (newChopTrackState t){ctsBOS = [g]}
l' = l ++ [st]
put l'
where
t = pageTrack g
pushHdr :: OggPage -> Chop ()
pushHdr g = do
ts <- findState g
let hdrs = ctsHdrs ts
h' = hdrs++[g]
replState ts{ctsHdrs = h'}
popBOSs :: Chop [OggPage]
popBOSs = popPages ctsBOS
popHdrs :: Chop [OggPage]
popHdrs = popPages ctsHdrs
popPages :: (ChopTrackState -> [OggPage]) -> Chop [OggPage]
popPages f = do
l <- get
let gs = foldr (\a b -> (f a)++b) [] l
return $ filter (not . contentTypeIs skeleton) gs
allEnded :: Chop Bool
allEnded = do
l <- get
return $ all ended l
getK :: OggPage -> Chop Integer
getK g = do
ts <- findState g
let c = prevK ts
return c
setK :: OggPage -> Chop ()
setK g = case (pageGranulepos g) of
Granulepos Nothing -> return ()
_ -> do
let k = fromJust $ pageKeyGranule g
ts <- findState g
replState ts{prevK = k}
changedK :: OggPage -> Chop Bool
changedK g = case (pageGranulepos g) of
Granulepos Nothing -> return False
_ -> do
c <- getK g
let k = fromJust $ pageKeyGranule g
return (k /= c)
chopAccum :: OggPage -> Chop ()
chopAccum g = case (trackGranuleshift t) of
Nothing -> return ()
_ -> do
ts <- findState g
let gs = pageAccum ts
replState ts{pageAccum = (g:gs)}
where
t = pageTrack g
pruneAccum :: OggPage -> Chop ()
pruneAccum g = case (trackGranuleshift t) of
Nothing -> return ()
_ -> do
k <- getK g
ts <- findState g
let ts' = pruneTrackAccum g k ts
replState ts'
where
t = pageTrack g
pruneTrackAccum :: OggPage -> Integer -> ChopTrackState -> ChopTrackState
pruneTrackAccum g k ts = ts{pageAccum = g:gs, ctsStartgranule = sg}
where
as = pageAccum ts
t = pageTrack g
(gs, sgs) = spanB later as
sg = gpOfHead sgs
gpOfHead [] = Granulepos Nothing
gpOfHead (x:_) = pageGranulepos x
later x = case (pageGranulepos x) of
Granulepos Nothing -> True
_ -> (fromJust $ gpToGranules (pageGranulepos x) t) >= k
getAccum :: Chop [OggPage]
getAccum = do
l <- get
let accums = foldr (\x b -> (reverse . pageAccum) x : b) [] l
as = listMerge accums
return as
addHeaders :: OggPage -> Chop ()
addHeaders g = do
let t = pageTrack g
h = trackHeaders t
modifyHeaders g h
subHeaders :: OggPage -> Chop ()
subHeaders g = do
let segs = length $ pageSegments g
incmplt = pageIncomplete g
n = if incmplt then (segs1) else segs
modifyHeaders g (n)
modifyHeaders :: OggPage -> Int -> Chop ()
modifyHeaders g n = do
ts <- findState g
let r = headersRemaining ts
replState ts{headersRemaining = r + n}
doneHeaders :: Chop Bool
doneHeaders = do
l <- get
return $ foldr (\t b -> (headersRemaining t <= 0) && b) True l
spanB :: (a -> Bool) -> [a] -> ([a], [a])
spanB _ [] = ([],[])
spanB p (x:xs)
| p x = (x:ys,zs)
| otherwise = ([x],xs)
where (ys,zs) = spanB p xs