Создаём GTK-видеоплеер с использованием Haskell

Когда мы в последний раз остановились на Movie Monad, мы создали десктопный видео-плеер, использующий все веб-технологии (HTML, CSS, JavaScript и Electron). Фокус был в том, что весь исходный код проекта был написан на Haskell.

Одним из ограничений нашего веб-подхода было то, что размер видео-файла не мог быть слишком большим, в противном случае приложение падало. Чтобы этого избежать, мы внедрили проверку размера файла и предупреждали пользователя о превышении ограничения.

Мы могли бы продолжить развивать наш подход с вебом, настроив бэкенд на стриминг видеофайла в HTML5-сервер, запустив параллельно сервер и Electron-приложение. Вместо этого мы откажемся от веб-технологий и обратимся к GTK+, Gstreamer и системе управления окнами X11.

Если вы используете другую систему управления окнами, например, Wayland, Quartz или WinAPI, то этот подход может быть адаптирован для работы с вашим GDK-бэкендом. Адаптация заключается во встраивании выходного видеосигнала GStreamer playbin в окно Movie Monad.

GDK — важный аспект портируемости GTK+. Поскольку Glib уже предоставляет низкоуровневую кроссплатформенную функциональность, то чтобы заставить GTK+ работать на других платформах вам нужно только портировать GDK на базовый графический уровень операционной системы. То есть именно GDK-порты на Windows API и Quartz позволяют приложениям GTK+ исполняться на Windows и macOS (источник).

Для кого эта статья

• Для программистов на Haskell, которые хотят реализовать пользовательский интерфейс на GTK+.
• Для программистов, интересующихся функциональным программированием.
• Для создателей GUI.
• Для тех, кто ищет альтернативы GitHub Electron.
• Для фанатов видео-плееров.

Что мы рассмотрим

• Stack.
• Привязки (bindings) haskell-gi
• Директорию различных данных и файлы с ними.
• Glade.
• GTK+.
• GStreamer.
• Как создать Movie Monad.

Настройка проекта

Сначала нам нужно настроить машину для разработки Haskell-программ, а также настроить файлы и зависимости для директории проекта.

Платформа Haskell

Если ваша машина ещё не готова к разработке Haskell-программ, то всё необходимое вы можете получить, скачав и установив платформу Haskell.

Stack

Если у вас ещё нет Stack, то обязательно установите его, прежде чем приступать к разработке. Но если вы уже пользовались платформой Haskell, то Stack у вас уже есть.

ExifTool

Прежде чем проигрывать видео в Movie Monad, нам нужно собрать кое-какую информацию о выбранном пользователем файле. Для этого воспользуемся ExifTool. Если вы работаете под Linux, то велик шанс, что у вас уже есть этот инструмент (which exiftool). ExifTool доступен для Windows, Mac и Linux.

Файлы проекта

Есть три способа получения файлов проекта.

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

Можете скачать ZIP-архив и извлечь их.

git clone [e-mail]:lettier/movie-monad.git
cd movie-monad/

Можете сделать Git-клон с помощью SSH.

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

Можете склонировать git через HTTPS.

haskell-gi

haskell-gi умеет генерировать Haskell-привязки (bindings) к библиотекам, использующим связующее ПО для самодиагностики (introspection middleware) GObject. На момент написания статьи все необходимые привязки доступны на Hackage.

Зависимости

Теперь устанавливаем зависимости проекта.

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

Код

Теперь настраиваем внедрение Movie Monad. Вы можете удалить исходные файлы и создать их заново, или следовать указаниям.

Paths_movie_monad.hs

Paths_movie_monad.hs используется для поиска файла Glade XML GUI во время runtime. Поскольку мы занимаемся разработкой, то будем использовать фиктивный модуль (dummy module) (movie-monad/src/dev/Paths_movie_monad.hs) для поиска файла movie-monad/src/data/gui.glade. После сборки/установки проекта реальный модуль Paths_movie_monad будет сгенерирован автоматически. Он предоставит нам функцию getDataFileName. Она присваивает своим выходным данным префикс в виде абсолютного пути, куда скопированы или установлены data-dir (movie-monad/src/) data-files.

{-# 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)

Фиктивный модуль Paths_movie_monad.

{-# 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)

Автоматически сгенерированный модуль Paths_movie_monad.

Main.hs

Main.hs — это входная точка для Movie Monad. В этом файле мы настраиваем наше окно с разными виджетами, подключаем GStreamer, а когда пользователь выходит, мы сносим окно.

Прагмы (Pragmas)

Нам нужно сказать компилятору (GHC), что нам нужны перегруженные (overloaded) строковые и лексически входящие в область видимости (lexically scoped) переменные типов.

OverloadedStrings позволяет нам использовать строковые литералы ("Literal") там, где требуются String/[Char] или Text. ScopedTypeVariables позволяет нам использовать сигнатуру типа в паттерне параметра лямбда-функции, передаваемую для перехвата при вызове ExifTool.

{-# 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

Поскольку мы работает с привязками Си, нам понадобится работать с типами, уже существующими в этом языке. Немалую часть импортов составляют привязки, генерируемые haskell-gi.

IsVideoOverlay

GStreamer-видеопривязки (gi-gstvideo) содержат класс типа (интерфейс) IsVideoOverlay. GStreamer-привязки (gi-gst) содержат тип элемента. Чтобы использовать элемент playbin с функцией GI.GstVideo.videoOverlaySetWindowHandle, нам нужно объявить GI.Gst.Element — экземпляр типа (type instance) IsVideoOverlay. А на стороне Cи playbin реализует интерфейс VideoOverlay.

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

Обратите внимание, что мы обёртываем GI.Gst.Element в новый тип (newtype), чтобы избежать появления потерянного (orphaned) экземпляра, поскольку мы объявляем экземпляр вне привязок haskell-gi.

main

Main — наша самая большая функция. В ней мы инициализируем все GUI-виджеты и определяем коллбэк-процедуры на основе определённых событий.

main :: IO ()
main = do

GI-инициализация

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

Здесь мы инициализировали GStreamer и GTK+.

Сборка GUI-виджетов

  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"

Как уже было сказано, мы получаем абсолютный путь к XML-файлу data/gui.glade, который описывает все наши GUI-виджеты. Дальше создаём из этого файла конструктор и получаем свои виджеты. Если бы мы не использовали Glade, то их пришлось бы создавать вручную, что довольно утомительно.

Playbin

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

Здесь мы создаём GStreamer-конвейер playbin. Он предназначен для решения самых разных нужд и экономит нам время на создании собственного конвейера. Назовём этот элемент MultimediaPlayer.

Встраиванние выходных данных GStreamer

Чтобы GTK+ и GStreamer заработали вместе, нам нужно сказать GStreamer, куда именно нужно выводить видео. Если этого не сделать, то GStreamer создаст собственное окно, поскольку мы используем playbin.

  _ <- 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

Здесь вы видите настройку коллбэка по мере готовности виджета drawingArea. Именно в этом виджете GStreamer должен показывать видео. Мы получаем родительское GDK-окно для виджета области отрисовки. Затем получаем обработчик окна, или XID системы X11 нашего окна GTK+. Строка CUIntPtr преобразует ID из CULong в CUIntPtr, необходимый для videoOverlaySetWindowHandle. Получив правильный тип, мы уведомляем GStreamer, что с помощью обработчика xid' он может отрисовывать в нашем окне выходные данные playbin.

Из-за бага в Glade мы программно скрываем полноэкранный виджет, поскольку если в Glade снять галочку visible box, то виджет всё-равно не будет спрятан.

Обратите внимание, что здесь нужно адаптировать Movie Monad для работы с оконной системой, если вы используете не Х-систему, а какую-то другую.

Выбор файла

  _ <- 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

Для начала сессии проигрывания видео, пользователь должен иметь возможность выбрать видео-файл. После того, как файл выбран, нужно выполнить ряд обязательных действий, чтобы всё работало хорошо.

• Получаем имя файла из виджета выбора файла.
• Говорим playbin, какой файл он должен воспроизвести.
• Делаем уровень громкомсти в виджете таким же, как в playbin.
• На основе желаемой ширины изображения и размера видео определяем подходящие ширину и высоту окна.
• Если размеры окна успешно получены:
  
  • Начинаем воспроизведение файла.
  • Переводим кнопку пауза/воспроизведение в состояние ”on”.
  • Показываем полноэкранный виджет.
  • Если видео не в полноэкранном режиме:
  • Меняем размер окна, чтобы оно совпало с относительным размером видео.
• Если не удалось получить размеры окна:
  
  • Ставим playbin на паузу.
  • Переводим переключатель в положение ”off”.
  • Если это возможно, выводим окно из полноэкранного режима.
  • Сбрасываем размер окна.
  • Выводим маленькое диалоговое сообщение об ошибке.

Пауза и воспроизведение

  _ <- 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

Всё просто. Если переключатель в положении ”on”, то задаём элементу playbin состояние воспроизведения. В противном случае задаём ему состояние паузы.

Настройка громкости

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

-- ...

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

При изменении уровня громкости в виджете мы передаём его значение в GStreamer, чтобы тот мог подстроить громкость воспроизведение.

Перемещение по видео

  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 есть шкала воспроизведения, в которой вы можете перемещать ползунок вперёд/назад, тем самым переходя по видеофреймам.

Шкала от 0 до 100% представляет общую длительность видео-файла. Если переместить ползунок, например, на 50, то мы перейдём к временной отметке, находящийся посередине между началом и окончанием. Можно было бы настроить шкалу от нуля до значения длительности видео, но описанный метод более универсален.

Обратите внимание, что для этого коллбэка мы используем сигнальный ID (seekScaleHandlerId), поскольку он понадобится нам позднее.

Обновление шкалы воспроизведения

  _ <- 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

Чтобы синхронизировать шкалу и сам процесс воспроизведения видео, нужно передавать сообщения между GTK+ и GStreamer. Каждую секунду мы будем запрашивать текущую позицию воспроизведения и в соответствии с ней обновлять шкалу. Так мы показываем пользователю, какая часть файла уже показана, а ползунок всегда будет соответствовать реальной позиции воспроизведения.

Чтобы не инициировать настроенный ранее коллбэк, мы отключаем обработчик сигнала onRangeValueChanged при обновлении шкалы воспроизведения. Коллбэк onRangeValueChanged должен быть выполнен только если пользователь изменит положение ползунка.

Изменение размеров видео

  _ <- 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

Этот виджет позволяет пользователю выбирать желаемую ширину видео. Высота будет подобрана автоматически на основе соотношения сторон видеофайла.

Полноэкранный режим

  _ <- 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

Когда пользователь отпускает кнопку виджета полноэкранного режим, мы переключаем состояние полноэкранного режима окна, скрываем панель выбора файла и виджет выбора ширины видео. При выходе из полноэкранного режима мы восстанавливаем панель и виджет.

Обратите внимание, что мы не показываем виджет полноэкранного режима, если у нас нет видео.

  _ <- 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

Для управления полноэкранным состоянием окна мы должны настроить коллбэк, чтобы он запускался при каждом изменении состояния окна. От информации о состоянии полноэкранности окна зависят различные коллбэки. В качестве помощи воспользуемся IORef, из которого будет читать каждая функция и в который будет писать коллбэк. Этот IORef является изменяемой (и общей) ссылкой. В идеале нам нужно запрашивать окно именно в то время, когда оно находится в полноэкранном режиме, но для этого не существует API. Поэтому будем использовать изменяемую ссылку.

Благодаря использованию в главном потоке выполнения единственного пишущего и кучи сигнальных коллбэков, мы избегаем возможных ловушек общего изменяемого состояния. Если бы нас заботила безопасность потока выполнения, то вместо этого мы могли бы использовать MVar, TVar или atomicModifyIORef.

О программе

  _ <- 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

Последний рассматриваемый виджет — диалоговое окно «О программе». Здесь мы связываем диалоговое окно с кнопкой «О программе», отображающейся в основном окне.

Закрытие окна

  _ <- 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

Когда пользователь закрывает окно, мы уничтожаем конвейер playbin и выходим из основного цикла GTK.

Запуск

  GI.Gtk.widgetShowAll window
  GI.Gtk.main

Наконец, мы показываем или отрисовываем главное окно и запускаем основной цикл GTK+. Он блокируется до вызова mainQuit.

Полный файл Main.hs

Ниже приведён файл movie-monad/src/Main.hs. Не показаны разные вспомогательные функции, относящиеся к 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

Собираем Movie Monad

Мы настроили наше сборочное окружение и подготовили весь исходный код, можно собирать Movie Monad и запускать исполняемый файл.

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`

Если всё в порядке, то Movie Monad должен запуститься.

Заключение

Пересмотрев проект Movie Monad, мы заново сделали приложение с помощью программных библиотек GTK+ и GStreamer. Благодаря им приложение осталось таким же портируемым, как и Electron-версия. Movie Monad теперь может обрабатывать большие видеофайлы и имеет все стандартные элементы управления.

Другим преимуществом использования GTK+ стало уменьшение потребления памяти. Если сравнивать резидентный размер в памяти при старте, то версия GTK+ занимает ~50 Мб, а версия Electron — ~300 Мб (500%-ное увеличение).

Наконец, вариант с GTK+ имеет меньше ограничений и требует меньше программирования. Для обеспечения такой же функциональности, вариант с Electron требует использования громоздкой клиент-серверной архитектуры. Но благодаря прекрасным сборкам haskell-gi мы смогли избежать решения на базе веба.

Если хотите посмотреть другие приложения, построенные с помощью GTK+ и Haskell, то обратите внимание на Gifcurry. Оно умеет брать видеофайлы и на их основе создавать гифки с наложенным текстом.