Lettier.com

Let's make a GTK Video Player with Haskell |

Overview

The UI of Movie Monad showing Sintel from the Blender Foundation.

The UI of Movie Monad showing Sintel from the Blender Foundation.

When we last left off with Movie Monad, we had built a desktop video player using all web-based technologies (HTML, CSS, JavaScript, and Electron). The twist was that all of the source code for the project was written in Haskell.

One of the limitations of our web-based approach was that the video file size could only be so large. If the file size was too large, it would crash the application. To avoid this, we put in a file size check and told the user if the video file was too large.

We could continue with the web-based approach and setup a back-end server to stream the video file to the HTML5 player and run the server and the Electron application side-by-side. Instead we will go with a non-web-based approach using GTK+, GStreamer, and the X11 windowing system. Note that if you use another windowing system, such as Wayland, Quartz, or WinAPI, this approach can be adapted to work with your particular GDK back-end. The adaptation part being the embedding of the GStreamer playbin video output into the Movie Monad window.

GDK is an important part of GTK+’s portability. Since low-level cross-platform functionality is already provided by GLib, all that is needed to make GTK+ run on other platforms is to port GDK to the underlying operating system’s graphics layer. Hence, the GDK ports to the Windows API and Quartz are what makes GTK+ applications run on Windows and macOS, respectively.

Who this is for

What we will cover

Project setup

Before we can begin, we will need our machine setup to develop Haskell programs and our project directory setup with its files and dependencies.

Haskell Platform

If your machine in not already setup to develop Haskell programs, you can obtain all that we will need by downloading and installing the Haskell Platform.

Stack

If you are setup to develop with Haskell but do not have Stack, make sure to get Stack installed before you begin. Note that if you used the Haskell Platform, you should already have Stack.

ExifTool

Before we can play a video in Movie Monad, we will need to gather some details about the file the user selected. We will be using ExifTool to gather these details. If you are using some Linux distribution, there is a good chance that you already have it (which exiftool). ExifTool is available for Windows, Mac, and Linux.

Project files

There are three ways you can obtain the project files.

wget https://github.com/lettier/movie-monad/archive/master.zip
unzip master.zip
mv movie-monad-master movie-monad
cd movie-monad/

You can download the ZIP and extract it.

git clone git@github.com:lettier/movie-monad.git
cd movie-monad/

You can Git clone it with SSH.

git clone https://github.com/lettier/movie-monad.git
cd movie-monad/

You can Git clone it with HTTPS.

haskell-gi

haskell-gi is capable of generating Haskell bindings for libraries that use the GObject introspection middleware. At the time of this writing, all of our needed bindings are on Hackage.

Dependencies

Go ahead now and install the project dependencies.

cd movie-monad/
stack install --dependencies-only

The code

We are now setup to implement Movie Monad. You can either delete the source files and recreate them or just follow along.

Paths_movie_monad.hs

Paths_movie_monad.hs is used to find our Glade XML GUI file at runtime. While we are developing, we use a dummy module (movie-monad/src/dev/Paths_movie_monad.hs) to find the movie-monad/src/data/gui.glade file. After we build/install the project, the real Paths_movie_monad module is auto generated. This auto generated module provides us with the getDataFileName function. getDataFileName prefixes its input with the absolute path to where the data-dir (movie-monad/src/) data-files were copied or installed to.

{-# LANGUAGE OverloadedStrings #-}

module Paths_movie_monad where

dataDir :: String
dataDir = "./src/"

getDataFileName :: FilePath -> IO FilePath
getDataFileName a = do
  putStrLn "You are using a fake Paths_movie_monad."
  return (dataDir ++ "/" ++ a)

The dummy Paths_movie_monad module.

{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}
{-# OPTIONS_GHC -fno-warn-implicit-prelude #-}
module Paths_movie_monad (
    version,
    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,
    getDataFileName, getSysconfDir
  ) where

import qualified Control.Exception as Exception
import Data.Version (Version(..))
import System.Environment (getEnv)
import Prelude

#if defined(VERSION_base)

#if MIN_VERSION_base(4,0,0)
catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
#else
catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a
#endif

#else
catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
#endif
catchIO = Exception.catch

version :: Version
version = Version [0,0,0,0] []
bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath

bindir     = "/home/<snip>/.stack-work/install/x86_64-linux-nopie/lts-9.1/8.0.2/bin"
libdir     = "/home/<snip>/.stack-work/install/x86_64-linux-nopie/lts-9.1/8.0.2/lib/x86_64-linux-ghc-8.0.2/movie-monad-0.0.0.0"
dynlibdir  = "/home/<snip>/.stack-work/install/x86_64-linux-nopie/lts-9.1/8.0.2/lib/x86_64-linux-ghc-8.0.2"
datadir    = "/home/<snip>/.stack-work/install/x86_64-linux-nopie/lts-9.1/8.0.2/share/x86_64-linux-ghc-8.0.2/movie-monad-0.0.0.0"
libexecdir = "/home/<snip>/.stack-work/install/x86_64-linux-nopie/lts-9.1/8.0.2/libexec"
sysconfdir = "/home/<snip>/.stack-work/install/x86_64-linux-nopie/lts-9.1/8.0.2/etc"

getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath
getBinDir = catchIO (getEnv "movie_monad_bindir") (\_ -> return bindir)
getLibDir = catchIO (getEnv "movie_monad_libdir") (\_ -> return libdir)
getDynLibDir = catchIO (getEnv "movie_monad_dynlibdir") (\_ -> return dynlibdir)
getDataDir = catchIO (getEnv "movie_monad_datadir") (\_ -> return datadir)
getLibexecDir = catchIO (getEnv "movie_monad_libexecdir") (\_ -> return libexecdir)
getSysconfDir = catchIO (getEnv "movie_monad_sysconfdir") (\_ -> return sysconfdir)

getDataFileName :: FilePath -> IO FilePath
getDataFileName name = do
  dir <- getDataDir
  return (dir ++ "/" ++ name)

The auto generated Paths_movie_monad module.

Main.hs

Main.hs is the entry point for Movie Monad. In this file we setup our window with its various widgets, we wire up GStreamer, and we teardown our window once the user exits.

Pragmas

We need to tell the compiler (GHC) that we want overloaded strings and lexically scoped type variables. OverloadedStrings allows us to use string literals ("Literal") in places that demand String/[Char] or Text. ScopedTypeVariables allows us to use a type signature in the parameter pattern of the lambda function passed to catch when calling ExifTool.

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

Imports

module Main where

import Prelude
import Foreign.C.Types
import System.Process
import System.Exit
import Control.Monad
import Control.Exception
import Text.Read
import Data.IORef
import Data.Maybe
import Data.Int
import Data.Text
import Data.GI.Base
import Data.GI.Base.Signals
import Data.GI.Base.Properties
import GI.GLib
import GI.GObject
import qualified GI.Gtk
import GI.Gst
import GI.GstVideo
import GI.Gdk
import GI.GdkX11
import Paths_movie_monad

Since we are dealing with C bindings, we will need to work with types that exist in the C language. A large portion of the imports are the bindings generated by haskell-gi.

IsVideoOverlay

The GStreamer video bindings (gi-gstvideo) have an IsVideoOverlay type class (interface). The GStreamer bindings (gi-gst) have an element type. In order to use playbin (an element) with the function GI.GstVideo.videoOverlaySetWindowHandle, we must declare GI.Gst.Element a type instance of IsVideoOverlay. On the C side, playbin implements the VideoOverlay interface.

newtype GstElement = GstElement GI.Gst.Element
instance GI.GstVideo.IsVideoOverlay GstElement

Note that we wrap GI.Gst.Element in a newtype to avoid an orphaned instance since we are declaring the instance outside of the haskell-gi bindings.

main

main is our largest function where we initialize all of the GUI widgets and define callback procedures based on certain events.

main :: IO ()
main = do

GI initialization

  _ <- GI.Gst.init Nothing
  _ <- GI.Gtk.init Nothing

Here we initialize GStreamer and GTK+.

Building our GUI widgets

  gladeFile <- getDataFileName "data/gui.glade"
  builder <- GI.Gtk.builderNewFromFile (pack gladeFile)

  window <- builderGetObject GI.Gtk.Window builder "window"
  fileChooserButton <- builderGetObject GI.Gtk.FileChooserButton builder "file-chooser-button"
  drawingArea <- builderGetObject GI.Gtk.Widget builder "drawing-area"
  seekScale <- builderGetObject GI.Gtk.Scale builder "seek-scale"
  onOffSwitch <- builderGetObject GI.Gtk.Switch builder "on-off-switch"
  volumeButton <- builderGetObject GI.Gtk.VolumeButton builder "volume-button"
  desiredVideoWidthComboBox <- builderGetObject GI.Gtk.ComboBoxText builder "desired-video-width-combo-box"
  fullscreenButton <- builderGetObject GI.Gtk.Button builder "fullscreen-button"
  errorMessageDialog <- builderGetObject GI.Gtk.MessageDialog builder "error-message-dialog"
  aboutButton <- builderGetObject GI.Gtk.Button builder "about-button"
  aboutDialog <- builderGetObject GI.Gtk.AboutDialog builder "about-dialog"

As described earlier, we obtain the absolute path to the data/gui.glade file which is a XML file describing all of our GUI widgets. Next we create a builder from the file and acquire each of our GUI widgets. If we didn’t use Glade, we would have had to build all of these widgets manually which can become rather verbose and tedious.

Playbin

  playbin <- fromJust <$> GI.Gst.elementFactoryMake "playbin" (Just "MultimediaPlayer")

Here we create a GStreamer pipeline called playbin. This pipeline is setup to handle a wide variety of needs and saves us the time of having to build our own pipeline. We give this element the name MultimediaPlayer.

Embedding the GStreamer output

Now that we have our window and playbin ready, we need to integrate the two. To integrate, we’ll inform GStreamer to render the video output from playbin into one of our window widgets. By doing this, the video will be embedded into the window. Note that if we didn’t inform GStreamer, it would create its own window since we are using the playbin element.

  _ <- GI.Gtk.onWidgetRealize drawingArea $ onDrawingAreaRealize drawingArea playbin fullscreenButton

-- ...

onDrawingAreaRealize ::
  GI.Gtk.Widget ->
  GI.Gst.Element ->
  GI.Gtk.Button ->
  GI.Gtk.WidgetRealizeCallback
onDrawingAreaRealize drawingArea playbin fullscreenButton = do
  gdkWindow <- fromJust <$> GI.Gtk.widgetGetWindow drawingArea
  x11Window <- GI.Gtk.unsafeCastTo GI.GdkX11.X11Window gdkWindow

  xid <- GI.GdkX11.x11WindowGetXid x11Window
  let xid' = fromIntegral xid :: CUIntPtr

  GI.GstVideo.videoOverlaySetWindowHandle (GstElement playbin) xid'

  GI.Gtk.widgetHide fullscreenButton

Here you see the callback setup for when our drawingArea widget is ready. The drawingArea is where we want GStreamer to render the video output from playbin. We obtain the parent GDK window for the drawing area widget. Next we get the window handle or XID of the X11 window powering our GTK+ window. The CUIntPtr line is converting the ID from CULong to CUIntPtr which videoOverlaySetWindowHandle expects. Once we have the correct type, we inform GStreamer that it can render the output of playbin to our window with the handle xid'.

Due to a bug in Glade, we programmatically hide the fullscreen widget here since unchecking the visible box in Glade does not hide the widget.

Note that here is where you would adapt Movie Monad to work with your windowing system if you are using something other than the X windowing system.

Choosing the file

  _ <- GI.Gtk.onFileChooserButtonFileSet fileChooserButton $
    onFileChooserButtonFileSet
      playbin
      fileChooserButton
      volumeButton
      isWindowFullScreenRef
      desiredVideoWidthComboBox
      onOffSwitch
      fullscreenButton
      drawingArea
      window
      errorMessageDialog

-- ...

onFileChooserButtonFileSet ::
  GI.Gst.Element ->
  GI.Gtk.FileChooserButton ->
  GI.Gtk.VolumeButton ->
  IORef Bool ->
  GI.Gtk.ComboBoxText ->
  GI.Gtk.Switch ->
  GI.Gtk.Button ->
  GI.Gtk.Widget ->
  GI.Gtk.Window ->
  GI.Gtk.MessageDialog ->
  GI.Gtk.FileChooserButtonFileSetCallback
onFileChooserButtonFileSet
  playbin
  fileChooserButton
  volumeButton
  isWindowFullScreenRef
  desiredVideoWidthComboBox
  onOffSwitch
  fullscreenButton
  drawingArea
  window
  errorMessageDialog
  = do
  _ <- GI.Gst.elementSetState playbin GI.Gst.StateNull

  filename <- fromJust <$> GI.Gtk.fileChooserGetFilename fileChooserButton

  setPlaybinUriAndVolume playbin filename volumeButton

  isWindowFullScreen <- readIORef isWindowFullScreenRef

  desiredVideoWidth <- getDesiredVideoWidth desiredVideoWidthComboBox
  maybeWindowSize <- getWindowSize desiredVideoWidth filename

  case maybeWindowSize of
    Nothing -> do
      _ <- GI.Gst.elementSetState playbin GI.Gst.StatePaused
      GI.Gtk.windowUnfullscreen window
      GI.Gtk.switchSetActive onOffSwitch False
      GI.Gtk.widgetHide fullscreenButton
      GI.Gtk.widgetShow desiredVideoWidthComboBox
      resetWindowSize desiredVideoWidth fileChooserButton drawingArea window
      _ <- GI.Gtk.onDialogResponse errorMessageDialog (\ _ -> GI.Gtk.widgetHide errorMessageDialog)
      void $ GI.Gtk.dialogRun errorMessageDialog
    Just (width, height) -> do
      _ <- GI.Gst.elementSetState playbin GI.Gst.StatePlaying
      GI.Gtk.switchSetActive onOffSwitch True
      GI.Gtk.widgetShow fullscreenButton
      unless isWindowFullScreen $ setWindowSize width height fileChooserButton drawingArea window

To kick off a video playing session, the user must be able to pick a video file. When they do pick a file, we must perform some critical steps to ensure everything goes smoothly.

Play and pause

  _ <- GI.Gtk.onSwitchStateSet onOffSwitch (onSwitchStateSet playbin)

-- ...

onSwitchStateSet ::
  GI.Gst.Element ->
  Bool ->
  IO Bool
onSwitchStateSet playbin switchOn = do
  if switchOn
    then void $ GI.Gst.elementSetState playbin GI.Gst.StatePlaying
    else void $ GI.Gst.elementSetState playbin GI.Gst.StatePaused
  return switchOn

Rather straight forward. If the toggle switch is on, we set the playbin element’s state to playing. Otherwise, we set the playbin element’s state to paused.

Setting the volume

  _ <- GI.Gtk.onScaleButtonValueChanged volumeButton (onScaleButtonValueChanged playbin)

-- ...

onScaleButtonValueChanged ::
  GI.Gst.Element ->
  Double ->
  IO ()
onScaleButtonValueChanged playbin volume =
    void $ Data.GI.Base.Properties.setObjectPropertyDouble playbin "volume" volume

Whenever the volume widget level changes, we forward this level on to GStreamer so that it can adjust the video volume.

Seek

  seekScaleHandlerId <- GI.Gtk.onRangeValueChanged seekScale (onRangeValueChanged playbin seekScale)

-- ...

onRangeValueChanged ::
  GI.Gst.Element ->
  GI.Gtk.Scale ->
  IO ()
onRangeValueChanged playbin seekScale = do
  (couldQueryDuration, duration) <- GI.Gst.elementQueryDuration playbin GI.Gst.FormatTime

  when couldQueryDuration $ do
    percentage' <- GI.Gtk.rangeGetValue seekScale
    let percentage = percentage' / 100.0
    let position = fromIntegral (round ((fromIntegral duration :: Double) * percentage) :: Int) :: Int64
    void $ GI.Gst.elementSeekSimple playbin GI.Gst.FormatTime [ GI.Gst.SeekFlagsFlush ] position

Movie Monad comes with a seek scale where as you drag the slider forwards or backwards, you move forwards or backwards through the video’s frames.

The scale of the seek slider is from zero to 100 and represents the percentage of video time passed. Advancing the slider to say 50, will move the video to the time marker that is half way between start and finish. We could set the slider’s scale to be from zero to however long the video is but this method allows us to generalize better.

Note that for this callback, we keep around the signal ID (seekScaleHandlerId) since we will need it later.

Seek Scale update

  _ <- GI.GLib.timeoutAddSeconds GI.GLib.PRIORITY_DEFAULT 1 (updateSeekScale playbin seekScale seekScaleHandlerId)

-- ...

updateSeekScale ::
  GI.Gst.Element ->
  GI.Gtk.Scale ->
  Data.GI.Base.Signals.SignalHandlerId ->
  IO Bool
updateSeekScale playbin seekScale seekScaleHandlerId = do
  (couldQueryDuration, duration) <- GI.Gst.elementQueryDuration playbin GI.Gst.FormatTime
  (couldQueryPosition, position) <- GI.Gst.elementQueryPosition playbin GI.Gst.FormatTime

  let percentage =
        if couldQueryDuration && couldQueryPosition && duration > 0
          then 100.0 * (fromIntegral position / fromIntegral duration :: Double)
          else 0.0

  GI.GObject.signalHandlerBlock seekScale seekScaleHandlerId
  GI.Gtk.rangeSetValue seekScale percentage
  GI.GObject.signalHandlerUnblock seekScale seekScaleHandlerId

  return True

To keep the seek scale in sync with the video’s progress, we must play messenger between GTK+ and GStreamer. Every second, we query the video’s current position and update the seek scale to match. By doing this, the user will know how far along they are and if they go to slide the seeker, it will be in the correct state.

As to not trigger the callback we setup earlier, we disable the onRangeValueChanged signal handler while we update the seek scale. The onRangeValueChanged callback should only run if the user changes the seek slider.

Changing the video size

  _ <- GI.Gtk.onComboBoxChanged desiredVideoWidthComboBox $
      onComboBoxChanged fileChooserButton desiredVideoWidthComboBox drawingArea window

-- ...

onComboBoxChanged ::
  GI.Gtk.FileChooserButton ->
  GI.Gtk.ComboBoxText ->
  GI.Gtk.Widget ->
  GI.Gtk.Window ->
  IO ()
onComboBoxChanged
  fileChooserButton
  desiredVideoWidthComboBox
  drawingArea
  window
  = do
  filename' <- GI.Gtk.fileChooserGetFilename fileChooserButton
  let filename = fromMaybe "" filename'

  desiredVideoWidth <- getDesiredVideoWidth desiredVideoWidthComboBox
  maybeWindowSize <- getWindowSize desiredVideoWidth filename

  case maybeWindowSize of
    Nothing -> resetWindowSize desiredVideoWidth fileChooserButton drawingArea window
    Just (width, height) -> setWindowSize width height fileChooserButton drawingArea window

This widget lets the user select the desired width of the video. The height of the window will be set based on the aspect ratio of the video and the user’s width selection.

Fullscreen

  _ <- GI.Gtk.onWidgetButtonReleaseEvent fullscreenButton
      (onFullscreenButtonRelease isWindowFullScreenRef desiredVideoWidthComboBox fileChooserButton window)

-- ...

onFullscreenButtonRelease ::
  IORef Bool ->
  GI.Gtk.ComboBoxText ->
  GI.Gtk.FileChooserButton ->
  GI.Gtk.Window ->
  GI.Gdk.EventButton ->
  IO Bool
onFullscreenButtonRelease
  isWindowFullScreenRef
  desiredVideoWidthComboBox
  fileChooserButton
  window
  _
  = do
  isWindowFullScreen <- readIORef isWindowFullScreenRef
  if isWindowFullScreen
    then do
      GI.Gtk.widgetShow desiredVideoWidthComboBox
      GI.Gtk.widgetShow fileChooserButton
      void $ GI.Gtk.windowUnfullscreen window
    else do
      GI.Gtk.widgetHide desiredVideoWidthComboBox
      GI.Gtk.widgetHide fileChooserButton
      void $ GI.Gtk.windowFullscreen window
  return True

Once the user releases the fullscreen widget button, we toggle the window’s fullscreen state. When going fullscreen, we hide the file chooser and the desired video width widget. When going out of fullscreen, we restore the file chooser and the desired video width widget.

Note that we do not show the fullscreen widget unless we have a valid video.

  _ <- GI.Gtk.onWidgetWindowStateEvent window (onWidgetWindowStateEvent isWindowFullScreenRef)

-- ...

onWidgetWindowStateEvent ::
  IORef Bool ->
  GI.Gdk.EventWindowState ->
  IO Bool
onWidgetWindowStateEvent isWindowFullScreenRef eventWindowState = do
  windowStates <- GI.Gdk.getEventWindowStateNewWindowState eventWindowState
  let isWindowFullScreen = Prelude.foldl (\ acc x -> acc || GI.Gdk.WindowStateFullscreen == x) False windowStates
  writeIORef isWindowFullScreenRef isWindowFullScreen
  return True

In order to manage the fullscreen state of the window, we must setup a callback to fire whenever the state of the window changes. Various callbacks rely on knowing the fullscreen state of the window. To facilitate this, we use an IORef that each function reads from and this callback writes to. This IORef is a mutable (and shared) reference. Ideally we would query the window at precisely the time we must know its fullscreen state but there is no API for this. Thus we must use this mutable reference.

With only one writer and all of our signal callbacks being run on the main thread, we avoid the may pitfalls of shared mutable state. If we were concerned about thread safety, we could use a MVar, TVar, or use atomicModifyIORef instead.

About

  _ <- GI.Gtk.onWidgetButtonReleaseEvent aboutButton (onAboutButtonRelease aboutDialog)

-- ...

onAboutButtonRelease ::
  GI.Gtk.AboutDialog ->
  GI.Gdk.EventButton ->
  IO Bool
onAboutButtonRelease aboutDialog _ = do
  _ <- GI.Gtk.onDialogResponse aboutDialog (\ _ -> GI.Gtk.widgetHide aboutDialog)
  _ <- GI.Gtk.dialogRun aboutDialog
  return True

The last widget we will cover is the about dialog window. Here we wire up the about dialog window to the about button shown on the main window.

Teardown

  _ <- GI.Gtk.onWidgetDestroy window (onWindowDestroy playbin)

-- ...

onWindowDestroy ::
  GI.Gst.Element ->
  IO ()
onWindowDestroy playbin = do
  _ <- GI.Gst.elementSetState playbin GI.Gst.StateNull
  _ <- GI.Gst.objectUnref playbin
  GI.Gtk.mainQuit

When the user destroys the window, destroy the playbin pipeline and quit the main GTK loop.

Startup

  GI.Gtk.widgetShowAll window
  GI.Gtk.main

At long last we show or render the main window and fire up the main GTK+ loop. This loop will block until mainQuit is called.

The entire Main.hs file

Below is the movie-monad/src/Main.hs file. The other portions not covered are various utility functions that dry up main.

{-
  Movie Monad
  (C) 2017 David lettier
  lettier.com
-}

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import Prelude
import Foreign.C.Types
import System.Process
import System.Exit
import Control.Monad
import Control.Exception
import Text.Read
import Data.IORef
import Data.Maybe
import Data.Int
import Data.Text
import Data.GI.Base
import Data.GI.Base.Signals
import Data.GI.Base.Properties
import GI.GLib
import GI.GObject
import qualified GI.Gtk
import GI.Gst
import GI.GstVideo
import GI.Gdk
import GI.GdkX11
import Paths_movie_monad

-- Declare Element a type instance of IsVideoOverlay via a newtype wrapper
-- Our GStreamer element is playbin
-- Playbin implements the GStreamer VideoOverlay interface
newtype GstElement = GstElement GI.Gst.Element
instance GI.GstVideo.IsVideoOverlay GstElement

main :: IO ()
main = do
  _ <- GI.Gst.init Nothing
  _ <- GI.Gtk.init Nothing

  gladeFile <- getDataFileName "data/gui.glade"
  builder <- GI.Gtk.builderNewFromFile (pack gladeFile)

  window <- builderGetObject GI.Gtk.Window builder "window"
  fileChooserButton <- builderGetObject GI.Gtk.FileChooserButton builder "file-chooser-button"
  drawingArea <- builderGetObject GI.Gtk.Widget builder "drawing-area"
  seekScale <- builderGetObject GI.Gtk.Scale builder "seek-scale"
  onOffSwitch <- builderGetObject GI.Gtk.Switch builder "on-off-switch"
  volumeButton <- builderGetObject GI.Gtk.VolumeButton builder "volume-button"
  desiredVideoWidthComboBox <- builderGetObject GI.Gtk.ComboBoxText builder "desired-video-width-combo-box"
  fullscreenButton <- builderGetObject GI.Gtk.Button builder "fullscreen-button"
  errorMessageDialog <- builderGetObject GI.Gtk.MessageDialog builder "error-message-dialog"
  aboutButton <- builderGetObject GI.Gtk.Button builder "about-button"
  aboutDialog <- builderGetObject GI.Gtk.AboutDialog builder "about-dialog"

  playbin <- fromJust <$> GI.Gst.elementFactoryMake "playbin" (Just "MultimediaPlayer")

  isWindowFullScreenRef <- newIORef False

  _ <- GI.Gtk.onWidgetRealize drawingArea $ onDrawingAreaRealize drawingArea playbin fullscreenButton

  _ <- GI.Gtk.onFileChooserButtonFileSet fileChooserButton $
    onFileChooserButtonFileSet
      playbin
      fileChooserButton
      volumeButton
      isWindowFullScreenRef
      desiredVideoWidthComboBox
      onOffSwitch
      fullscreenButton
      drawingArea
      window
      errorMessageDialog

  _ <- GI.Gtk.onSwitchStateSet onOffSwitch (onSwitchStateSet playbin)

  _ <- GI.Gtk.onScaleButtonValueChanged volumeButton (onScaleButtonValueChanged playbin)

  seekScaleHandlerId <- GI.Gtk.onRangeValueChanged seekScale (onRangeValueChanged playbin seekScale)

  _ <- GI.GLib.timeoutAddSeconds GI.GLib.PRIORITY_DEFAULT 1 (updateSeekScale playbin seekScale seekScaleHandlerId)

  _ <- GI.Gtk.onComboBoxChanged desiredVideoWidthComboBox $
      onComboBoxChanged fileChooserButton desiredVideoWidthComboBox drawingArea window

  _ <- GI.Gtk.onWidgetButtonReleaseEvent fullscreenButton
      (onFullscreenButtonRelease isWindowFullScreenRef desiredVideoWidthComboBox fileChooserButton window)

  _ <- GI.Gtk.onWidgetWindowStateEvent window (onWidgetWindowStateEvent isWindowFullScreenRef)

  _ <- GI.Gtk.onWidgetButtonReleaseEvent aboutButton (onAboutButtonRelease aboutDialog)

  _ <- GI.Gtk.onWidgetDestroy window (onWindowDestroy playbin)

  GI.Gtk.widgetShowAll window
  GI.Gtk.main

builderGetObject ::
  (GI.GObject.GObject b, GI.Gtk.IsBuilder a) =>
  (Data.GI.Base.ManagedPtr b -> b) ->
  a ->
  Prelude.String ->
  IO b
builderGetObject objectTypeClass builder objectId =
  fromJust <$> GI.Gtk.builderGetObject builder (pack objectId) >>=
    GI.Gtk.unsafeCastTo objectTypeClass

onDrawingAreaRealize ::
  GI.Gtk.Widget ->
  GI.Gst.Element ->
  GI.Gtk.Button ->
  GI.Gtk.WidgetRealizeCallback
onDrawingAreaRealize drawingArea playbin fullscreenButton = do
  gdkWindow <- fromJust <$> GI.Gtk.widgetGetWindow drawingArea
  x11Window <- GI.Gtk.unsafeCastTo GI.GdkX11.X11Window gdkWindow

  xid <- GI.GdkX11.x11WindowGetXid x11Window
  let xid' = fromIntegral xid :: CUIntPtr

  GI.GstVideo.videoOverlaySetWindowHandle (GstElement playbin) xid'

  GI.Gtk.widgetHide fullscreenButton

onFileChooserButtonFileSet ::
  GI.Gst.Element ->
  GI.Gtk.FileChooserButton ->
  GI.Gtk.VolumeButton ->
  IORef Bool ->
  GI.Gtk.ComboBoxText ->
  GI.Gtk.Switch ->
  GI.Gtk.Button ->
  GI.Gtk.Widget ->
  GI.Gtk.Window ->
  GI.Gtk.MessageDialog ->
  GI.Gtk.FileChooserButtonFileSetCallback
onFileChooserButtonFileSet
  playbin
  fileChooserButton
  volumeButton
  isWindowFullScreenRef
  desiredVideoWidthComboBox
  onOffSwitch
  fullscreenButton
  drawingArea
  window
  errorMessageDialog
  = do
  _ <- GI.Gst.elementSetState playbin GI.Gst.StateNull

  filename <- fromJust <$> GI.Gtk.fileChooserGetFilename fileChooserButton

  setPlaybinUriAndVolume playbin filename volumeButton

  isWindowFullScreen <- readIORef isWindowFullScreenRef

  desiredVideoWidth <- getDesiredVideoWidth desiredVideoWidthComboBox
  maybeWindowSize <- getWindowSize desiredVideoWidth filename

  case maybeWindowSize of
    Nothing -> do
      _ <- GI.Gst.elementSetState playbin GI.Gst.StatePaused
      GI.Gtk.windowUnfullscreen window
      GI.Gtk.switchSetActive onOffSwitch False
      GI.Gtk.widgetHide fullscreenButton
      GI.Gtk.widgetShow desiredVideoWidthComboBox
      resetWindowSize desiredVideoWidth fileChooserButton drawingArea window
      _ <- GI.Gtk.onDialogResponse errorMessageDialog (\ _ -> GI.Gtk.widgetHide errorMessageDialog)
      void $ GI.Gtk.dialogRun errorMessageDialog
    Just (width, height) -> do
      _ <- GI.Gst.elementSetState playbin GI.Gst.StatePlaying
      GI.Gtk.switchSetActive onOffSwitch True
      GI.Gtk.widgetShow fullscreenButton
      unless isWindowFullScreen $ setWindowSize width height fileChooserButton drawingArea window

onSwitchStateSet ::
  GI.Gst.Element ->
  Bool ->
  IO Bool
onSwitchStateSet playbin switchOn = do
  if switchOn
    then void $ GI.Gst.elementSetState playbin GI.Gst.StatePlaying
    else void $ GI.Gst.elementSetState playbin GI.Gst.StatePaused
  return switchOn

onScaleButtonValueChanged ::
  GI.Gst.Element ->
  Double ->
  IO ()
onScaleButtonValueChanged playbin volume =
    void $ Data.GI.Base.Properties.setObjectPropertyDouble playbin "volume" volume

onRangeValueChanged ::
  GI.Gst.Element ->
  GI.Gtk.Scale ->
  IO ()
onRangeValueChanged playbin seekScale = do
  (couldQueryDuration, duration) <- GI.Gst.elementQueryDuration playbin GI.Gst.FormatTime

  when couldQueryDuration $ do
    percentage' <- GI.Gtk.rangeGetValue seekScale
    let percentage = percentage' / 100.0
    let position = fromIntegral (round ((fromIntegral duration :: Double) * percentage) :: Int) :: Int64
    void $ GI.Gst.elementSeekSimple playbin GI.Gst.FormatTime [ GI.Gst.SeekFlagsFlush ] position

updateSeekScale ::
  GI.Gst.Element ->
  GI.Gtk.Scale ->
  Data.GI.Base.Signals.SignalHandlerId ->
  IO Bool
updateSeekScale playbin seekScale seekScaleHandlerId = do
  (couldQueryDuration, duration) <- GI.Gst.elementQueryDuration playbin GI.Gst.FormatTime
  (couldQueryPosition, position) <- GI.Gst.elementQueryPosition playbin GI.Gst.FormatTime

  let percentage =
        if couldQueryDuration && couldQueryPosition && duration > 0
          then 100.0 * (fromIntegral position / fromIntegral duration :: Double)
          else 0.0

  GI.GObject.signalHandlerBlock seekScale seekScaleHandlerId
  GI.Gtk.rangeSetValue seekScale percentage
  GI.GObject.signalHandlerUnblock seekScale seekScaleHandlerId

  return True

onComboBoxChanged ::
  GI.Gtk.FileChooserButton ->
  GI.Gtk.ComboBoxText ->
  GI.Gtk.Widget ->
  GI.Gtk.Window ->
  IO ()
onComboBoxChanged
  fileChooserButton
  desiredVideoWidthComboBox
  drawingArea
  window
  = do
  filename' <- GI.Gtk.fileChooserGetFilename fileChooserButton
  let filename = fromMaybe "" filename'

  desiredVideoWidth <- getDesiredVideoWidth desiredVideoWidthComboBox
  maybeWindowSize <- getWindowSize desiredVideoWidth filename

  case maybeWindowSize of
    Nothing -> resetWindowSize desiredVideoWidth fileChooserButton drawingArea window
    Just (width, height) -> setWindowSize width height fileChooserButton drawingArea window

onFullscreenButtonRelease ::
  IORef Bool ->
  GI.Gtk.ComboBoxText ->
  GI.Gtk.FileChooserButton ->
  GI.Gtk.Window ->
  GI.Gdk.EventButton ->
  IO Bool
onFullscreenButtonRelease
  isWindowFullScreenRef
  desiredVideoWidthComboBox
  fileChooserButton
  window
  _
  = do
  isWindowFullScreen <- readIORef isWindowFullScreenRef
  if isWindowFullScreen
    then do
      GI.Gtk.widgetShow desiredVideoWidthComboBox
      GI.Gtk.widgetShow fileChooserButton
      void $ GI.Gtk.windowUnfullscreen window
    else do
      GI.Gtk.widgetHide desiredVideoWidthComboBox
      GI.Gtk.widgetHide fileChooserButton
      void $ GI.Gtk.windowFullscreen window
  return True

onWidgetWindowStateEvent ::
  IORef Bool ->
  GI.Gdk.EventWindowState ->
  IO Bool
onWidgetWindowStateEvent isWindowFullScreenRef eventWindowState = do
  windowStates <- GI.Gdk.getEventWindowStateNewWindowState eventWindowState
  let isWindowFullScreen = Prelude.foldl (\ acc x -> acc || GI.Gdk.WindowStateFullscreen == x) False windowStates
  writeIORef isWindowFullScreenRef isWindowFullScreen
  return True

onAboutButtonRelease ::
  GI.Gtk.AboutDialog ->
  GI.Gdk.EventButton ->
  IO Bool
onAboutButtonRelease aboutDialog _ = do
  _ <- GI.Gtk.onDialogResponse aboutDialog (\ _ -> GI.Gtk.widgetHide aboutDialog)
  _ <- GI.Gtk.dialogRun aboutDialog
  return True

onWindowDestroy ::
  GI.Gst.Element ->
  IO ()
onWindowDestroy playbin = do
  _ <- GI.Gst.elementSetState playbin GI.Gst.StateNull
  _ <- GI.Gst.objectUnref playbin
  GI.Gtk.mainQuit

setPlaybinUriAndVolume ::
  GI.Gst.Element ->
  Prelude.String ->
  GI.Gtk.VolumeButton ->
  IO ()
setPlaybinUriAndVolume playbin filename volumeButton = do
  let uri = "file://" ++ filename
  volume <- GI.Gtk.scaleButtonGetValue volumeButton
  Data.GI.Base.Properties.setObjectPropertyDouble playbin "volume" volume
  Data.GI.Base.Properties.setObjectPropertyString playbin "uri" (Just $ pack uri)

getVideoInfo :: Prelude.String -> Prelude.String -> IO (Maybe Prelude.String)
getVideoInfo flag filename = do
  (code, out, _) <- catch (
      readProcessWithExitCode
        "exiftool"
        [flag, "-s", "-S", filename]
        ""
    ) (\ (_ :: Control.Exception.IOException) -> return (ExitFailure 1, "", ""))
  if code == System.Exit.ExitSuccess
    then return (Just out)
    else return Nothing

isVideo :: Prelude.String -> IO Bool
isVideo filename = do
  maybeOut <- getVideoInfo "-MIMEType" filename
  case maybeOut of
    Nothing -> return False
    Just out -> return ("video" `isInfixOf` pack out)

getWindowSize :: Int -> Prelude.String -> IO (Maybe (Int32, Int32))
getWindowSize desiredVideoWidth filename =
  isVideo filename >>=
  getWidthHeightString >>=
  splitWidthHeightString >>=
  widthHeightToDouble >>=
  ratio >>=
  windowSize
  where
    getWidthHeightString :: Bool -> IO (Maybe Prelude.String)
    getWidthHeightString False = return Nothing
    getWidthHeightString True = getVideoInfo "-ImageSize" filename
    splitWidthHeightString :: Maybe Prelude.String -> IO (Maybe [Text])
    splitWidthHeightString Nothing = return Nothing
    splitWidthHeightString (Just string) = return (Just (Data.Text.splitOn "x" (pack string)))
    widthHeightToDouble :: Maybe [Text] -> IO (Maybe Double, Maybe Double)
    widthHeightToDouble (Just (x:y:_)) = return (readMaybe (unpack x) :: Maybe Double, readMaybe (unpack y) :: Maybe Double)
    widthHeightToDouble _ = return (Nothing, Nothing)
    ratio :: (Maybe Double, Maybe Double) -> IO (Maybe Double)
    ratio (Just width, Just height) =
      if width <= 0.0 then return Nothing else return (Just (height / width))
    ratio _ = return Nothing
    windowSize :: Maybe Double -> IO (Maybe (Int32, Int32))
    windowSize Nothing = return Nothing
    windowSize (Just ratio') =
      return (Just (fromIntegral desiredVideoWidth :: Int32, round ((fromIntegral desiredVideoWidth :: Double) *  ratio') :: Int32))

getDesiredVideoWidth :: GI.Gtk.ComboBoxText -> IO Int
getDesiredVideoWidth = fmap (\ x -> read (Data.Text.unpack x) :: Int) . GI.Gtk.comboBoxTextGetActiveText

setWindowSize ::
  Int32 ->
  Int32 ->
  GI.Gtk.FileChooserButton ->
  GI.Gtk.Widget ->
  GI.Gtk.Window ->
  IO ()
setWindowSize width height fileChooserButton drawingArea window = do
  GI.Gtk.setWidgetWidthRequest fileChooserButton width

  GI.Gtk.setWidgetWidthRequest drawingArea width
  GI.Gtk.setWidgetHeightRequest drawingArea height

  GI.Gtk.setWidgetWidthRequest window width
  GI.Gtk.setWidgetHeightRequest window height
  GI.Gtk.windowResize window width (if height <= 0 then 1 else height)

resetWindowSize ::
  (Integral a) =>
  a ->
  GI.Gtk.FileChooserButton ->
  GI.Gtk.Widget ->
  GI.Gtk.Window ->
  IO ()
resetWindowSize width' fileChooserButton drawingArea window = do
  let width = fromIntegral width' :: Int32
  GI.Gtk.widgetQueueDraw drawingArea
  setWindowSize width 0 fileChooserButton drawingArea window

Building Movie Monad

Now that we have setup our build environment and have all of the source code in place, we can build Movie Monad and run the executable/binary.

cd movie-monad/
stack clean
stack install
stack exec -- movie-monad
# Or just `movie-monad` if `stack path | grep local-bin-path` is in your `echo $PATH`

If all is in order, Movie Monad should run.

Recap

Revisiting the Movie Monad project, we remade the application using the software libraries GTK+ and GStreamer. By using GTK+ and GStreamer, the application remains as portable as the Electron version. Movie Monad can now handle large video files and comes with all of the standard controls one would expect.

Another benefit to the GTK+ approach is the smaller footprint. Comparing the resident size in memory on start up, the GTK+ version only requires ~50 MB while the Electron version requires ~300 MB (a 500% increase).

In the end, the GTK+ approach came with fewer limitations and required less engineering. To offer the same functionality, the Electron approach would require a tedious client server architecture. However, thanks to the excellent haskell-gi bindings, we were able to avoid the web-based approach altogether.

If you would like to see another GTK+ application built with Haskell, be sure to checkout Gifcurry. Gifcurry allows you take video files and produce GIFs optionally overlaid with text.

Hi there! Browse and subscribe to the RSS feed for more content.

2017 David Lettier