movie-monad-0.0.5.0: src/Playbin.hs
{-
Movie Monad
(C) 2017 David Lettier
lettier.com
-}
{-# LANGUAGE OverloadedStrings, ForeignFunctionInterface #-}
module Playbin where
import Control.Monad
import Foreign.C
import Foreign.Ptr
import Data.Bits
import Data.Text
import Data.Maybe
import Data.Int
import Data.GI.Base.Properties
import Data.GI.Base.ManagedPtr
import qualified GI.GLib
import qualified GI.Gtk
import qualified GI.Gst
import qualified Records as R
import Reset
import PlayPause
import ErrorMessage
import Uri
foreign import ccall "gst-ffi.h get_text_tag_list"
c_getTextTagList :: Ptr a -> CInt -> IO (Ptr b)
addPlaybinHandlers :: R.Application -> IO ()
addPlaybinHandlers
application@R.Application
{ R.guiObjects =
R.GuiObjects
{ R.volumeButton = volumeButton
, R.repeatCheckButton = repeatCheckButton
}
, R.playbin = playbin
, R.playbinBus = playbinBus
}
= do
void $
GI.Gst.busAddWatch playbinBus GI.GLib.PRIORITY_DEFAULT $
pipelineBusMessageHandler application
void $
GI.Gtk.onScaleButtonValueChanged
volumeButton
(setPlaybinVolume playbin)
void $
GI.GLib.timeoutAddSeconds GI.GLib.PRIORITY_DEFAULT 1 $ do
rewindPlaybackIfVideoEndedAndRepeat
playbin
repeatCheckButton
return True
pipelineBusMessageHandler
:: R.Application
-> GI.Gst.Bus
-> GI.Gst.Message
-> IO Bool
pipelineBusMessageHandler
application@R.Application
{ R.guiObjects =
R.GuiObjects
{ R.seekScale = seekScale
, R.fileChooserEntry = fileChooserEntry
, R.fileChooserButtonLabel = fileChooserButtonLabel
, R.errorMessageDialog = errorMessageDialog
, R.bufferingSpinner = bufferingSpinner
, R.playPauseButton = playPauseButton
, R.repeatCheckButton = repeatCheckButton
, R.subtitleSelectionComboBoxText = subtitleSelectionComboBoxText
}
, R.playbin = playbin
}
_
message
= do
messageTypes <- GI.Gst.getMessageType message
let messageType =
case messageTypes of
[] -> GI.Gst.MessageTypeUnknown
(msg:_) -> msg
entryText <- GI.Gtk.entryGetText fileChooserEntry
labelText <- GI.Gtk.labelGetText fileChooserButtonLabel
when
( messageType == GI.Gst.MessageTypeError
&& ((not . Data.Text.null) entryText || labelText /= "Open")
) $ do
(gError, text) <- GI.Gst.messageParseError message
gErrorText <- GI.Gst.gerrorMessage gError
putStr ((Data.Text.unpack . Data.Text.unlines) [text, gErrorText])
resetApplication application
runErrorMessageDialog
errorMessageDialog $
Data.Text.concat
["There was a problem trying to play the video \"", entryText, "\"."]
when (messageType == GI.Gst.MessageTypeBuffering) $ do
percent <- GI.Gst.messageParseBuffering message
isPlaying <- isPlayPauseButtonPlaying playPauseButton
if percent >= 100
then do
GI.Gtk.widgetHide bufferingSpinner
GI.Gtk.setSpinnerActive bufferingSpinner False
GI.Gtk.widgetSetSensitive seekScale True
when isPlaying $
void $
GI.Gst.elementSetState playbin GI.Gst.StatePlaying
else do
GI.Gtk.widgetShow bufferingSpinner
GI.Gtk.setSpinnerActive bufferingSpinner True
GI.Gtk.widgetSetSensitive seekScale False
void $ GI.Gst.elementSetState playbin GI.Gst.StatePaused
return ()
when (messageType == GI.Gst.MessageTypeStreamStart) $ do
turnOffSubtitles playbin
nText <- getTextStreamCount playbin
GI.Gtk.comboBoxTextRemoveAll subtitleSelectionComboBoxText
GI.Gtk.comboBoxTextAppend
subtitleSelectionComboBoxText
(Just "-1")
"None"
_ <- GI.Gtk.comboBoxSetActiveId subtitleSelectionComboBoxText (Just "-1")
GI.Gtk.widgetHide subtitleSelectionComboBoxText
when (nText > 0) $
mapM_ (\ i -> do
(_, maybeCode) <- getTextTagLanguageNameAndCode playbin i
case maybeCode of
Nothing -> return ()
Just code -> do
GI.Gtk.widgetShow subtitleSelectionComboBoxText
GI.Gtk.comboBoxTextAppend
subtitleSelectionComboBoxText
(Just (Data.Text.pack (show i)))
code
) [0..(nText-1)]
when (messageType == GI.Gst.MessageTypeEos) $
rewindPlaybackIfRepeat playbin repeatCheckButton
return True
rewindPlaybackIfVideoEndedAndRepeat :: GI.Gst.Element -> GI.Gtk.CheckButton -> IO ()
rewindPlaybackIfVideoEndedAndRepeat playbin repeatCheckButton = do
maybeDurationAndPosition <- queryPlaybinForDurationAndPosition playbin
case maybeDurationAndPosition of
(Just (duration, position)) ->
-- Position may never be >= duration even though an EOS event has occurred.
-- Allow for a half second tolerance.
when (position >= duration || ((duration - position) < 50000000)) $
rewindPlaybackIfRepeat playbin repeatCheckButton
_ -> return ()
rewindPlaybackIfRepeat :: GI.Gst.Element -> GI.Gtk.CheckButton -> IO ()
rewindPlaybackIfRepeat playbin repeatCheckButton = do
repeatVideo <- GI.Gtk.toggleButtonGetActive repeatCheckButton
when repeatVideo $
void $
GI.Gst.elementSeekSimple playbin GI.Gst.FormatTime [ GI.Gst.SeekFlagsFlush ] 0
setPlaybinVolume :: GI.Gst.Element -> Double -> IO ()
setPlaybinVolume playbin volume =
void $ Data.GI.Base.Properties.setObjectPropertyDouble playbin "volume" volume
setPlaybinUri :: GI.Gst.Element -> Maybe String -> IO ()
setPlaybinUri playbin (Just uri) =
void $ Data.GI.Base.Properties.setObjectPropertyString playbin "uri" (Just $ pack uri)
setPlaybinUri playbin Nothing =
void $ Data.GI.Base.Properties.setObjectPropertyString playbin "uri" (Just "")
setPlaybinUriAndVolume :: GI.Gst.Element -> Prelude.String -> GI.Gtk.VolumeButton -> IO ()
setPlaybinUriAndVolume playbin fileName volumeButton = do
uri <- addUriSchemeIfNone fileName
volume <- GI.Gtk.scaleButtonGetValue volumeButton
setPlaybinVolume playbin volume
setPlaybinUri playbin (Just uri)
queryPlaybinForDurationAndPosition :: GI.Gst.Element -> IO (Maybe (Int64, Int64))
queryPlaybinForDurationAndPosition playbin = do
(couldQueryDuration, duration) <- GI.Gst.elementQueryDuration playbin GI.Gst.FormatTime
(couldQueryPosition, position) <- GI.Gst.elementQueryPosition playbin GI.Gst.FormatTime
if couldQueryDuration && couldQueryPosition && duration > 0 && position >= 0
then return (Just (duration, position))
else return Nothing
getTextTagLanguageNameAndCode :: GI.Gst.Element -> Int -> IO (Maybe Text, Maybe Text)
getTextTagLanguageNameAndCode playbin streamId = do
nText <- getTextStreamCount playbin
if streamId >= 0 && streamId < nText
then
withManagedPtr playbin $ \ playbinPtr -> do
let streamId' = fromIntegral streamId :: CInt
tagListPtr <- c_getTextTagList playbinPtr streamId'
if tagListPtr == nullPtr
then return (Nothing, Nothing)
else do
tagList <- wrapBoxed GI.Gst.TagList tagListPtr
tagListAsString <- fmap (fromMaybe "") (GI.Gst.tagListToString tagList)
(successName, name) <-
if "language-name" `Data.Text.isInfixOf` tagListAsString
then GI.Gst.tagListGetString tagList "language-name"
else return (False, "")
(successCode, code) <-
if "language-code" `Data.Text.isInfixOf` tagListAsString
then GI.Gst.tagListGetString tagList "language-code"
else return (False, "")
return
( if successName then Just name else Nothing
, if successCode then Just code else Nothing
)
else return (Nothing, Nothing)
turnOnSubtitles :: GI.Gst.Element -> IO ()
turnOnSubtitles playbin = do
-- Flags "GstPlayFlags" Default: 0x00000617, "soft-colorbalance+deinterlace+soft-volume+text+audio+video"
-- (0x00000001): video - Render the video stream
-- (0x00000002): audio - Render the audio stream
-- (0x00000004): text - Render subtitles
-- (0x00000008): vis - Render visualisation when no video is present
-- (0x00000010): soft-volume - Use software volume
-- (0x00000020): native-audio - Only use native audio formats
-- (0x00000040): native-video - Only use native video formats
-- (0x00000080): download - Attempt progressive download buffering
-- (0x00000100): buffering - Buffer demuxed/parsed data
-- (0x00000200): deinterlace - Deinterlace video if necessary
-- (0x00000400): soft-colorbalance - Use software color balance
-- (0x00000800): force-filters - Force audio/video filter(s) to be applied
-- 0110 0001 0111
let flags = flip setBit 10 $ flip setBit 9 $ flip setBit 4 $ flip setBit 2 $ flip setBit 1 $ bit 0
void $ Data.GI.Base.Properties.setObjectPropertyInt playbin "flags" flags
turnOffSubtitles :: GI.Gst.Element -> IO ()
turnOffSubtitles playbin = do
let flags = flip setBit 10 $ flip setBit 9 $ flip setBit 4 $ flip setBit 1 $ bit 0
void $ Data.GI.Base.Properties.setObjectPropertyInt playbin "flags" flags
getTextStreamCount :: GI.Gst.Element -> IO Int
getTextStreamCount playbin =
Data.GI.Base.Properties.getObjectPropertyInt playbin "n-text" >>=
\ x -> return (if x < 0 then 0 else fromIntegral x :: Int)
getCurrentTextStreamId :: GI.Gst.Element -> IO Int
getCurrentTextStreamId playbin =
Data.GI.Base.Properties.getObjectPropertyInt playbin "current-text" >>=
\ x -> return (fromIntegral x :: Int)
setCurrentTextStreamId :: GI.Gst.Element -> Int -> IO ()
setCurrentTextStreamId playbin streamId =
Data.GI.Base.Properties.setObjectPropertyInt
playbin
"current-text"
(fromIntegral streamId :: CInt)