GstPlayer.hs

{-
 *  Programmer:	Piotr Borek
 *  E-mail:     piotrborek@op.pl
 *  Copyright 2016 Piotr Borek
 *
 *  Distributed under the terms of the GPL (GNU Public License)
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}

module Mp.Player.GstPlayer (
    GstPlayer (),
    initGstPlayer,
    gstPlayerAddIdle,
    gstPlayerTimeoutAdd,
    gstPlayerMainLoopBlocking,
    gstBusAddWatch,
    gstPlayerGetTimeInfo,
    gstPlayerQuit,
    gstPlayerPlay,
    gstPlayerPause,
    gstPlayerStop,
    gstPlayerResume,
    gstPlayerSetVolume,
    gstPlayerSeek
) where

import qualified Data.GI.Base.Properties   as G
import qualified Data.Text                 as T
import qualified GI.GLib                   as G
import qualified GI.Gst                    as G

import           Control.Monad
import           Control.Monad.Catch
import           Control.Monad.IO.Class
import           Data.Maybe
import           Data.Typeable
import           Data.Word

import           Mp.Locale.TranslateFile   ()
import           Simple.Locale.TranslateTH

data GstPlayerException = GstPlayerElementFactoryException T.Text
                        | GstPlayerElementLinkException (Maybe T.Text) (Maybe T.Text)
                        deriving Typeable

instance Exception GstPlayerException

instance Show GstPlayerException where
    show (GstPlayerElementFactoryException text) = [tr|GstPlayerElementFactoryException: Could not create element|] ++ " \"" ++ show text ++ "\"."
    show (GstPlayerElementLinkException nameA nameB) = [tr|GstPlayerElementLinkException: Could not link elements|] ++ ": " ++ show nameA ++ " -> " ++ show nameB ++ "."

data GstPlayer = GstPlayer {
    gstPlayerSource   :: G.Element,
    gstPlayerConvert  :: G.Element,
    gstPlayerVolume   :: G.Element,
    gstPlayerPipeline :: G.Pipeline,
    gstPlayerMainLoop :: G.MainLoop
}

elementMake :: (MonadIO m, MonadThrow m) => String -> m G.Element
elementMake name = do
    let name' = T.pack name
    element <- liftIO $ G.elementFactoryMake name' $ Just name'
    case element of
        Just element' -> return element'
        Nothing       -> throwM $ GstPlayerElementFactoryException name'

elementLink :: (MonadIO m, MonadThrow m) => G.Element -> G.Element -> m ()
elementLink a b = do
    ok <- G.elementLink a b
    unless ok $ do
        nameA <- G.objectGetName a
        nameB <- G.objectGetName b
        throwM $ GstPlayerElementLinkException nameA nameB

initGstPlayer :: (MonadIO m, MonadThrow m) => m GstPlayer
initGstPlayer = do
    liftIO $ void $ G.init Nothing

    mainLoop <- liftIO $ G.mainLoopNew Nothing True

    source   <- elementMake "uridecodebin"
    convert  <- elementMake "audioconvert"
    volume   <- elementMake "volume"
    sink     <- elementMake "autoaudiosink"

    pipeline <- liftIO $ G.pipelineNew (Just "pipeline")

    mapM_ (G.binAdd pipeline) [source, convert, volume, sink]

    elementLink convert volume
    elementLink volume sink

    let gstPlayer = GstPlayer source convert volume pipeline mainLoop

    void $ G.onElementPadAdded source (padAddedHandler gstPlayer)

    return gstPlayer

padAddedHandler :: GstPlayer -> G.Pad -> IO ()
padAddedHandler gstPlayer pad = do
    sinkPad <- G.elementGetStaticPad (gstPlayerConvert gstPlayer) "sink"
    when (isJust sinkPad) $ do
        isLinked <- G.padIsLinked $ fromJust sinkPad
        unless isLinked $ do
            padCaps <- G.padGetCurrentCaps pad
            when (isJust padCaps) $ do
                capsStruct <- G.capsGetStructure (fromJust padCaps) 0
                structName <- G.structureGetName capsStruct
                when (T.take 11 structName == "audio/x-raw") $ G.padLink pad (fromJust sinkPad) >> return ()

gstPlayerMainLoopBlocking :: MonadIO m => GstPlayer -> m ()
gstPlayerMainLoopBlocking player = liftIO $ G.mainLoopRun $ gstPlayerMainLoop player

gstBusAddWatch :: MonadIO m => GstPlayer -> G.BusFunc -> m ()
gstBusAddWatch player action = do
    bus <- G.pipelineGetBus $ gstPlayerPipeline player
    void $ G.busAddWatch bus G.PRIORITY_DEFAULT action

gstPlayerGetTimeInfo :: MonadIO m => GstPlayer -> m (Maybe (Integer, Integer))
gstPlayerGetTimeInfo player = liftIO $ do
    (hasPosition, position) <- G.elementQueryPosition (gstPlayerPipeline player) G.FormatTime
    (hasDuration, duration) <- G.elementQueryDuration (gstPlayerPipeline player) G.FormatTime
    if (and [hasPosition, hasDuration])
        then
            return $ Just (fromIntegral (position `div` fromIntegral G.SECOND) :: Integer, fromIntegral (duration `div` fromIntegral G.SECOND) :: Integer)
        else
            return Nothing

-- Functions below can be called from any thread
gstPlayerAddIdle :: MonadIO m => IO Bool -> m ()
gstPlayerAddIdle callback = liftIO $ void $ G.idleAdd G.PRIORITY_DEFAULT_IDLE callback

gstPlayerTimeoutAdd :: MonadIO m => Word32 -> IO Bool -> m ()
gstPlayerTimeoutAdd time action = liftIO $ void $ G.timeoutAdd G.PRIORITY_DEFAULT_IDLE time action

gstPlayerQuit :: MonadIO m => GstPlayer -> m ()
gstPlayerQuit player = gstPlayerAddIdle $ do
    G.mainLoopQuit $ gstPlayerMainLoop player
    return False

gstPlayerPlay :: MonadIO m => GstPlayer -> FilePath -> m ()
gstPlayerPlay player file = gstPlayerAddIdle $ do
    let pipeline = gstPlayerPipeline player
    let source   = gstPlayerSource player
    uri <- G.uriEscapeString (T.pack $ "file://" ++ file) (Just ":/") True
    void $ G.elementSetState pipeline G.StateNull
    G.setObjectPropertyString source "uri" (Just uri)
    G.setObjectPropertyInt source "buffer-size" (4 * 1024 * 1024)
    void $ G.elementSetState pipeline G.StatePlaying
    return False

gstPlayerPause :: MonadIO m => GstPlayer -> m ()
gstPlayerPause player = gstPlayerAddIdle $ do
    void $ G.elementSetState (gstPlayerPipeline player) G.StatePaused
    return False

gstPlayerStop :: MonadIO m => GstPlayer -> m ()
gstPlayerStop player = gstPlayerAddIdle $ do
    void $ G.elementSetState (gstPlayerPipeline player) G.StateNull
    return False

gstPlayerResume :: MonadIO m => GstPlayer -> m ()
gstPlayerResume player = gstPlayerAddIdle $ do
    void $ G.elementSetState (gstPlayerPipeline player) G.StatePlaying
    return False

gstPlayerSetVolume :: MonadIO m => GstPlayer -> Double -> m ()
gstPlayerSetVolume player vol = gstPlayerAddIdle $ do
    G.setObjectPropertyDouble (gstPlayerVolume player) "volume" vol
    return False

gstPlayerSeek :: MonadIO m => GstPlayer -> Integer -> m ()
gstPlayerSeek player pos = gstPlayerAddIdle $ do
    void $ G.elementSeekSimple (gstPlayerPipeline player) G.FormatTime [G.SeekFlagsFlush] $ fromIntegral $ pos * fromIntegral G.SECOND
    return False