diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,84 @@ +# [Movie Monad](https://github.com/lettier/movie-monad) + +## Changelog + +### 0.0.2.0 + +#### Added + +- Hides the cursor and the on-screen controls when the mouse is idle +- New Logo +- URL support +- Keyboard shortcuts +- makefile +- Icon +- AppImage +- AppImage installation script +- Support for GTK 3.10 +- macOS screenshots +- macOS build instructions +- Screensaver and power management enable/disable +- Video file path command line option that, if present, plays the video on window realized + +#### Changed + +- Cabal file + - Corrected source-repository +- Logo +- README +- Dependencies +- Icon +- Play/Pause toggle to button +- ICO file to PNG +- Switched from GstVideoOverlay to GtkSink + +#### Removed + +- ExifTool requirement +- Old logo PNG file +- X11 dependency + +------------------------------------------------------------------------------- + +### 0.0.1.0 + +#### Added + +- Fullscreen mode + +#### Changed + +- Screenshot +- Main function + - Extracted callback functions into their own functions +- Dependencies to match Hackage + +#### Removed + +- `lib` directory + +------------------------------------------------------------------------------- + +### 0.0.0.0 + +#### Added + +- File Loader +- Seek +- Pause +- Play +- Window Width Selector +- About +- Screenshot +- Logo +- README +- LICENSE +- Documentation + +#### Changed + +- + +#### Removed + +- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -![Movie Monad](https://i.imgur.com/Vt9Bipy.png) +![Movie Monad](https://i.imgur.com/gdsyIMv.png) # Movie Monad @@ -6,30 +6,157 @@ ## Screenshots -![GUI showing Sintel from the Blender Foundation](https://i.imgur.com/SLse3s9.jpg) +![GUI showing Sintel from the Blender Foundation](https://i.imgur.com/UBNYbER.jpg) -## Documentation +![GUI showing Big Buck Bunny from the Blender Foundation](https://i.imgur.com/Tgmk7SW.png) -[Let's make a GTK Video Player with Haskell](https://lettier.github.io/posts/2017-08-30-haskell-gtk-video-player.html) +![GUI showing the About window as seen on the Mac](https://i.imgur.com/hiix2Wm.png) -## Install +## Features -### GitHub +* Local or remote video file playback + * `file://` + * `http://` + * `https://` +* Window size selection +* Fullscreen mode +* Seek +* Play and pause +* Volume +* Command line play + * `movie-monad ./path/to/video/file.mp4` + * `movie-monad http://www.domain.tld/path/to/video/file.mp4` +## Keyboard Shortcuts + +* Mute/Unmute + * `m` + * `AudioMute` +* Fullscreen/Windowed + * `f` +* Show Controls + * `c` +* Volume Up + * `ArrowUp` + * `AudioRaiseVolume` +* Volume Down + * `ArrowDown` + * `AudioLowerVolume` +* Play/Pause + * `Space` + * `AudioPlay` + +## Tested On + +### Linux + +* [Ubuntu 17.10](https://www.ubuntu.com/desktop) +* [Ubuntu 16.04](https://www.ubuntu.com/desktop) +* [Ubuntu 14.04](https://www.ubuntu.com/desktop) +* [Linux Mint 18.2](https://linuxmint.com/) +* [Manjaro 17.04](https://manjaro.org/) +* [Deepin 15.4.1](https://www.deepin.org/en/dde/) +* [Antergos 17.10](https://antergos.com/) + +### Mac + +* [macOS Sierra 10.12.6](https://en.wikipedia.org/wiki/MacOS_Sierra) + +## Dependencies + +### Run + +* [GTK+ >= 3.10](https://www.gtk.org/download/index.php) +* [GStreamer >= 1.0](https://gstreamer.freedesktop.org/download/) + * [GStreamer Good Plug-ins](https://gstreamer.freedesktop.org/modules/gst-plugins-good.html) + * [GStreamer Bad Plug-ins](https://gstreamer.freedesktop.org/modules/gst-plugins-bad.html) + +### Build + +* [Haskell](https://www.haskell.org/platform/prior.html) + * GHC == 8.0.2 + +## Install & Run + +### Linux + +#### AppImage + ```bash -# Install Git -# Install XQuartz (https://www.xquartz.org/) if using Mac OSX or macOS -# Install GTK+ 3.* (https://www.gtk.org/download/index.php) -# Install Haskell -# Install Haksell Stack -# Install ExifTool +# Install GTK+ >= 3.10 (https://www.gtk.org/download/index.php) +# Install GStreamer >= 1.0 (https://gstreamer.freedesktop.org/download/) +# Install GStreamer Good Plug-ins (https://gstreamer.freedesktop.org/modules/gst-plugins-good.html) +# Install GStreamer Bad Plug-ins >= 1.8 (https://gstreamer.freedesktop.org/modules/gst-plugins-bad.html) +# Visit https://github.com/lettier/movie-monad/releases +# * equals the current version +# Download the latest AppImage movie-monad-*-x86_64.AppImage +wget https://github.com/lettier/movie-monad/releases/download/*/movie-monad-*-x86_64.AppImage +chmod a+x movie-monad-*-x86_64.AppImage +./movie-monad-*-x86_64.AppImage +# If you would like to install the AppImage, you can run the following +cd +wget "https://raw.githubusercontent.com/lettier/movie-monad/master/packaging/linux/movie-monad-install.sh" -O "movie-monad-install.sh" +chmod +x "movie-monad-install.sh" +./movie-monad-install.sh +``` + +### Mac + +```bash +# Install Homebrew (https://brew.sh/#install) +cd ~/Downloads +brew update && brew upgrade +brew install git git clone https://github.com/lettier/movie-monad.git -cd movie-monad/ +cd movie-monad +brew cask install haskell-platform +brew install pkg-config libffi libav libsvg librsvg libogg libvorbis openh264 theora \ + gobject-introspection cairo gdk-pixbuf gsettings-desktop-schemas gtk+3 gtk-mac-integration \ + gstreamer gst-libav gst-plugins-base gst-plugins-good +brew install --with-gtk+3 gst-plugins-bad stack setup +stack install hsc2hs stack install -stack exec -- movie-monad -# Or just `movie-monad` if `stack path | grep local-bin-path` is in your `echo $PATH` +export PATH=$PATH:"$HOME/.local/bin/" +movie-monad ``` + +### [Hackage](https://hackage.haskell.org/package/movie-monad) + +```bash +# Install GObject Introspection (https://wiki.gnome.org/action/show/Projects/GObjectIntrospection) +# Install GTK+ >= 3.10 (https://www.gtk.org/download/index.php) +# Install GStreamer >= 1.0 (https://gstreamer.freedesktop.org/download/) +# Install GStreamer Good Plug-ins (https://gstreamer.freedesktop.org/modules/gst-plugins-good.html) +# Install GStreamer Bad Plug-ins >= 1.8 (https://gstreamer.freedesktop.org/modules/gst-plugins-bad.html) +# Install Cabal, GHC == 8.0.2 (https://www.haskell.org/platform/prior.html) +# Install Cabal Install (https://www.haskell.org/platform/prior.html) +cabal install movie-monad +movie-monad +``` + +### [GitHub](https://github.com/lettier/movie-monad) + +```bash +# Install GObject Introspection (https://wiki.gnome.org/action/show/Projects/GObjectIntrospection) +# Install GTK+ >= 3.10 (https://www.gtk.org/download/index.php) +# Install GStreamer >= 1.0 (https://gstreamer.freedesktop.org/download/) +# Install GStreamer Good Plug-ins (https://gstreamer.freedesktop.org/modules/gst-plugins-good.html) +# Install GStreamer Bad Plug-ins >= 1.8 (https://gstreamer.freedesktop.org/modules/gst-plugins-bad.html) +# Install Git (https://git-scm.com/downloads) +# Install GNU Make (https://www.gnu.org/software/make/) +# Install Haskell, GHC == 8.0.2 (https://www.haskell.org/platform/prior.html) +# Install Haksell Stack (https://www.haskell.org/platform/) +git clone https://github.com/lettier/movie-monad.git +cd movie-monad/ +make +make install +make run +``` + +## Developer Documentation + +[Let's make a GTK Video Player with Haskell](https://lettier.github.io/posts/2017-08-30-haskell-gtk-video-player.html) ## License diff --git a/movie-monad.cabal b/movie-monad.cabal --- a/movie-monad.cabal +++ b/movie-monad.cabal @@ -1,5 +1,5 @@ name: movie-monad -version: 0.0.1.0 +version: 0.0.2.0 synopsis: Plays videos using GStreamer and GTK+. description: Desktop video player that uses GStreamer and GTK+. homepage: https://github.com/lettier/movie-monad @@ -8,38 +8,84 @@ author: Lettier maintainer: Lettier copyright: 2017 David Lettier -category: Multimedia +category: Application + , Multimedia , Multimedia Player , Video build-type: Simple -cabal-version: >=1.10 +cabal-version: >= 1.10 extra-source-files: README.md , LICENSE + , CHANGELOG.md , ./src/dev/Paths_movie_monad.hs , ./src/data/gui.glade -data-files: data/gui.glade + , ./src/data/movie-monad-logo.svg + , ./src/data/movie-monad-icon.png + , ./src/Records.hs + , ./src/Constants.hs + , ./src/Window.hs + , ./src/CommandLine.hs + , ./src/Keyboard.hs + , ./src/Mouse.hs + , ./src/FileChooser.hs + , ./src/Seek.hs + , ./src/PlayPause.hs + , ./src/VideoSizeSelector.hs + , ./src/Fullscreen.hs + , ./src/ErrorMessage.hs + , ./src/About.hs + , ./src/VideoInfo.hs + , ./src/Playbin.hs + , ./src/Uri.hs + , ./src/Utils.hs + , ./src/ScreensaverAndPowerManagement.hs +data-files: data/gui.glade + , data/movie-monad-logo.svg + , data/movie-monad-icon.png data-dir: ./src/ source-repository head type: git - location: https://github.com/lettier/gifcurry.git + location: https://github.com/lettier/movie-monad.git executable movie-monad main-is: Main.hs default-language: Haskell2010 build-depends: base >= 4.7 && < 5 + , filepath == 1.4.* + , system-fileio == 0.3.* + , system-filepath == 0.4.* , text == 1.2.* + , time == 1.6.* , process == 1.4.* , MissingH == 1.4.* - , haskell-gi-base == 0.20.* - , gi-xlib == 2.0.* + , network-uri == 2.6.* + , haskell-gi-base == 0.20.4 , gi-gobject == 2.0.* , gi-glib == 2.0.* - , gi-gdkx11 == 3.0.* - , gi-gstvideo == 1.0.* , gi-gdk == 3.0.* + , gi-gdkpixbuf == 2.0.* , gi-gst == 1.0.* - , gi-gtk == 3.0.* - ghc-options: -threaded -with-rtsopts=-N -Wall - other-modules: Paths_movie_monad + , gi-gstvideo == 1.0.* + , gi-gtk == 3.0.18 + ghc-options: -threaded -with-rtsopts=-N -Wall -freverse-errors + other-modules: Paths_movie_monad + , Records + , Constants + , Window + , CommandLine + , Keyboard + , Mouse + , FileChooser + , Seek + , PlayPause + , VideoSizeSelector + , Fullscreen + , ErrorMessage + , About + , VideoInfo + , Uri + , Playbin + , Utils + , ScreensaverAndPowerManagement hs-source-dirs: ./src/ diff --git a/src/About.hs b/src/About.hs new file mode 100644 --- /dev/null +++ b/src/About.hs @@ -0,0 +1,39 @@ +{- + Movie Monad + (C) 2017 David lettier + lettier.com +-} + +module About where + +import Control.Monad +import qualified GI.Gdk +import qualified GI.Gtk + +import qualified Records as R + +addAboutHandler :: R.Application -> IO () +addAboutHandler + R.Application { + R.guiObjects = R.GuiObjects { + R.aboutButton = aboutButton + , R.aboutDialog = aboutDialog + } + } + = + void ( + GI.Gtk.onWidgetButtonReleaseEvent aboutButton (aboutButtonReleaseHandler aboutDialog) + ) + +aboutButtonReleaseHandler :: + GI.Gtk.AboutDialog -> + GI.Gdk.EventButton -> + IO Bool +aboutButtonReleaseHandler aboutDialog _ = + void ( + GI.Gtk.onDialogResponse aboutDialog (\ _ -> GI.Gtk.widgetHide aboutDialog) + ) >> + void ( + GI.Gtk.dialogRun aboutDialog + ) >> + return True diff --git a/src/CommandLine.hs b/src/CommandLine.hs new file mode 100644 --- /dev/null +++ b/src/CommandLine.hs @@ -0,0 +1,32 @@ +{- + Movie Monad + (C) 2017 David lettier + lettier.com +-} + +module CommandLine where + +import System.Environment +import Data.Text +import GI.Gtk + +import qualified Records as R +import FileChooser +import Uri +import Utils + +playVideoFromCommandLineIfNeeded :: R.Application -> IO () +playVideoFromCommandLineIfNeeded + application@R.Application { + R.guiObjects = R.GuiObjects { + R.fileChooserEntry = fileChooserEntry + } + } + = do + args <- getArgs + case args of + [] -> return () + (filePath':_) -> do + filePath <- toAbsoluteUri filePath' + GI.Gtk.entrySetText fileChooserEntry (Data.Text.pack filePath) + fileChooserDialogResponseHandler application (enumToInt32 GI.Gtk.ResponseTypeOk) diff --git a/src/Constants.hs b/src/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Constants.hs @@ -0,0 +1,17 @@ +{- + Movie Monad + (C) 2017 David lettier + lettier.com +-} + +{-# LANGUAGE OverloadedStrings #-} + +module Constants where + +import Data.Text + +hideOnScreenControlsInterval :: Integral a => a +hideOnScreenControlsInterval = 5 + +invalidVideoWidgetName :: Data.Text.Text +invalidVideoWidgetName = "invalid-video-widget" diff --git a/src/ErrorMessage.hs b/src/ErrorMessage.hs new file mode 100644 --- /dev/null +++ b/src/ErrorMessage.hs @@ -0,0 +1,42 @@ +{- + Movie Monad + (C) 2017 David lettier + lettier.com +-} + +{-# LANGUAGE OverloadedStrings #-} + +module ErrorMessage where + +import Control.Monad +import Data.Text +import Data.Int +import qualified GI.Gtk + +import qualified Records as R + +addErrorMessageDialogHandler :: R.Application -> IO () +addErrorMessageDialogHandler + R.Application { + R.guiObjects = R.GuiObjects { + R.errorMessageDialog = errorMessageDialog + } + } + = + void (GI.Gtk.onDialogResponse errorMessageDialog (errorMessageDialogResponseHandler errorMessageDialog)) + +errorMessageDialogResponseHandler :: + GI.Gtk.MessageDialog -> + Int32 -> + IO () +errorMessageDialogResponseHandler errorMessageDialog _ = + GI.Gtk.widgetHide errorMessageDialog >> + GI.Gtk.setMessageDialogText errorMessageDialog "There was an error." + +runErrorMessageDialog :: + GI.Gtk.MessageDialog -> + Text -> + IO () +runErrorMessageDialog errorMessageDialog text = + GI.Gtk.setMessageDialogText errorMessageDialog text >> + void (GI.Gtk.dialogRun errorMessageDialog) diff --git a/src/FileChooser.hs b/src/FileChooser.hs new file mode 100644 --- /dev/null +++ b/src/FileChooser.hs @@ -0,0 +1,190 @@ +{- + Movie Monad + (C) 2017 David lettier + lettier.com +-} + +{-# LANGUAGE OverloadedStrings #-} + +module FileChooser where + +import Control.Monad +import Data.Int +import Data.Text +import Data.IORef +import qualified Network.URI +import qualified GI.Gdk +import qualified GI.Gtk +import qualified GI.Gst + +import qualified Records as R +import Constants +import Window +import PlayPause +import ErrorMessage +import VideoInfo +import Playbin +import Uri +import Utils + +addFileChooserHandlers :: R.Application -> IO () +addFileChooserHandlers + application@R.Application { + R.guiObjects = R.GuiObjects { + R.fileChooserButton = fileChooserButton + , R.fileChooserDialog = fileChooserDialog + , R.fileChooserWidget = fileChooserWidget + , R.fileChooserEntry = fileChooserEntry + } + } + = + void (GI.Gtk.onWidgetButtonReleaseEvent fileChooserButton (fileChooserButtonClickHandler application)) >> + void (GI.Gtk.onDialogResponse fileChooserDialog (fileChooserDialogResponseHandler application)) >> + void (GI.Gtk.onFileChooserSelectionChanged fileChooserWidget (fileChooserSelectionChangedHandler application)) >> + void (GI.Gtk.onEntryIconRelease fileChooserEntry (\ _ _ -> GI.Gtk.entrySetText fileChooserEntry "")) + +fileChooserDialogResponseHandler :: + R.Application -> + Int32 -> + IO () +fileChooserDialogResponseHandler + R.Application { + R.guiObjects = guiObjects@R.GuiObjects { + R.window = window + , R.fileChooserButton = fileChooserButton + , R.videoWidget = videoWidget + , R.seekScale = seekScale + , R.playPauseButton = playPauseButton + , R.videoWidthSelectionComboBox = videoWidthSelectionComboBox + , R.fullscreenButton = fullscreenButton + , R.fileChooserEntry = fileChooserEntry + , R.fileChooserButtonLabel = fileChooserButtonLabel + , R.volumeButton = volumeButton + , R.errorMessageDialog = errorMessageDialog + , R.fileChooserDialog = fileChooserDialog + , R.playImage = playImage + , R.pauseImage = pauseImage + } + , R.ioRefs = R.IORefs { + R.isWindowFullScreenRef = isWindowFullScreenRef + , R.videoInfoRef = videoInfoRef + , R.previousFileNamePathRef = previousFileNamePathRef + } + , R.playbin = playbin + } + responseId + = do + GI.Gtk.widgetHide fileChooserDialog + handleResponseType GI.Gtk.ResponseTypeOk + where + handleResponseType :: (Enum a, Ord a) => a -> IO () + handleResponseType enum + | enumToInt32 enum == responseId = do + _ <- GI.Gst.elementSetState playbin GI.Gst.StateNull + filePathName <- GI.Gtk.entryGetText fileChooserEntry + let filePathNameStr = Data.Text.unpack filePathName + (_, fileNameEmpty) <- setFileChooserButtonLabel fileChooserButtonLabel filePathName + isWindowFullScreen <- readIORef isWindowFullScreenRef + videoWidthSelection <- getSelectedVideoWidth videoWidthSelectionComboBox + setPlaybinUriAndVolume playbin filePathNameStr volumeButton + handleFileName + fileNameEmpty + filePathNameStr + isWindowFullScreen + videoWidthSelection + | otherwise = do + filePathName <- readIORef previousFileNamePathRef + _ <- setFileChooserButtonLabel fileChooserButtonLabel filePathName + GI.Gtk.entrySetText fileChooserEntry filePathName + handleFileName :: + Bool -> + Prelude.String -> + Bool -> + Int -> + IO () + handleFileName True _ _ _ = atomicWriteIORef videoInfoRef R.defaultVideoInfo >> resetWindow guiObjects + handleFileName + _ + filePathNameStr + isWindowFullScreen + videoWidthSelection + = do + retrievedVideoInfo <- getVideoInfo videoInfoRef filePathNameStr + maybeWindowSize <- calculateWindowSize videoWidthSelection retrievedVideoInfo + GI.Gtk.widgetSetSensitive seekScale True + if R.isSeekable retrievedVideoInfo + then GI.Gtk.widgetShow seekScale + else GI.Gtk.widgetHide seekScale + case maybeWindowSize of + Nothing -> do + resetWindow guiObjects + runErrorMessageDialog + errorMessageDialog + (Data.Text.pack $ Prelude.concat ["\"", filePathNameStr, "\" is not a video."]) + Just (width, height) -> do + videoWidgetName <- GI.Gtk.widgetGetName videoWidget + if videoWidgetName == invalidVideoWidgetName + then do + resetWindow guiObjects + runErrorMessageDialog + errorMessageDialog + "Cannot play the video. Please install the bad plugins, version 1.8 or higher, for GStreamer version 1." + else do + GI.Gtk.widgetShow videoWidget + GI.Gtk.widgetShow playPauseButton + GI.Gtk.widgetShow fullscreenButton + setPlayPauseButton playPauseButton playImage pauseImage True + unless isWindowFullScreen $ + setWindowSize width height fileChooserButton videoWidget window + void $ GI.Gst.elementSetState playbin GI.Gst.StatePlaying + +fileChooserButtonClickHandler :: + R.Application -> + GI.Gdk.EventButton -> + IO Bool +fileChooserButtonClickHandler + R.Application { + R.guiObjects = R.GuiObjects { + R.fileChooserEntry = fileChooserEntry + , R.fileChooserDialog = fileChooserDialog + } + , R.ioRefs = R.IORefs { + R.previousFileNamePathRef = previousFileNamePathRef + } + } + _ + = do + text <- GI.Gtk.entryGetText fileChooserEntry + atomicWriteIORef previousFileNamePathRef text + _ <- GI.Gtk.dialogRun fileChooserDialog + return True + +fileChooserSelectionChangedHandler :: + R.Application -> + IO () +fileChooserSelectionChangedHandler + R.Application { + R.guiObjects = R.GuiObjects { + R.fileChooserWidget = fileChooserWidget + , R.fileChooserEntry = fileChooserEntry + } + , R.ioRefs = R.IORefs { + R.videoInfoRef = videoInfoRef + } + } + = do + maybeUri <- GI.Gtk.fileChooserGetUri fileChooserWidget + case maybeUri of + Nothing -> return () + Just uri' -> do + let uri = Network.URI.unEscapeString $ Data.Text.unpack uri' + local <- isLocalFile uri + video <- R.isVideo <$> getVideoInfo videoInfoRef uri + GI.Gtk.entrySetText fileChooserEntry (if local && video then Data.Text.pack uri else "") + +setFileChooserButtonLabel :: GI.Gtk.Label -> Data.Text.Text -> IO (Data.Text.Text, Bool) +setFileChooserButtonLabel fileChooserButtonLabel filePathName = do + let fileName = fileNameFromFilePathName filePathName + let fileNameEmpty = isTextEmpty fileName + GI.Gtk.labelSetText fileChooserButtonLabel (if fileNameEmpty then "Open" else fileName) + return (fileName, fileNameEmpty) diff --git a/src/Fullscreen.hs b/src/Fullscreen.hs new file mode 100644 --- /dev/null +++ b/src/Fullscreen.hs @@ -0,0 +1,53 @@ +{- + Movie Monad + (C) 2017 David lettier + lettier.com +-} + +module Fullscreen where + +import Control.Monad +import Data.IORef +import qualified GI.Gdk +import qualified GI.Gtk + +import qualified Records as R + +addFullscreenButtonReleaseHandler :: R.Application -> IO () +addFullscreenButtonReleaseHandler + application@R.Application { + R.guiObjects = R.GuiObjects { + R.fullscreenButton = fullscreenButton + } + } + = + void $ GI.Gtk.onWidgetButtonReleaseEvent fullscreenButton (fullscreenButtonReleaseHandler application) + +fullscreenButtonReleaseHandler :: + R.Application -> + GI.Gdk.EventButton -> + IO Bool +fullscreenButtonReleaseHandler + R.Application { + R.guiObjects = R.GuiObjects { + R.window = window + , R.fileChooserButton = fileChooserButton + , R.videoWidthSelectionComboBox = videoWidthSelectionComboBox + } + , R.ioRefs = R.IORefs { + R.isWindowFullScreenRef = isWindowFullScreenRef + } + } + _ + = do + isWindowFullScreen <- readIORef isWindowFullScreenRef + if isWindowFullScreen + then do + GI.Gtk.widgetShow videoWidthSelectionComboBox + GI.Gtk.widgetShow fileChooserButton + void $ GI.Gtk.windowUnfullscreen window + else do + GI.Gtk.widgetHide videoWidthSelectionComboBox + GI.Gtk.widgetHide fileChooserButton + void $ GI.Gtk.windowFullscreen window + return True diff --git a/src/Keyboard.hs b/src/Keyboard.hs new file mode 100644 --- /dev/null +++ b/src/Keyboard.hs @@ -0,0 +1,74 @@ +{- + Movie Monad + (C) 2017 David lettier + lettier.com +-} + +module Keyboard where + +import Control.Monad +import Data.IORef +import qualified GI.Gdk +import qualified GI.Gtk + +import qualified Records as R +import Mouse +import PlayPause +import Fullscreen + +addKeyboardEventHandler :: R.Application -> IO () +addKeyboardEventHandler + application@R.Application { + R.guiObjects = R.GuiObjects { + R.window = window + } + } + = + void $ GI.Gtk.onWidgetKeyPressEvent window $ keyboardEventHandler application + +keyboardEventHandler :: + R.Application -> + GI.Gdk.EventKey -> + IO Bool +keyboardEventHandler + application@R.Application { + R.guiObjects = R.GuiObjects { + R.volumeButton = volumeButton + } + , R.ioRefs = R.IORefs { + R.videoInfoRef = videoInfoRef + } + } + eventKey + = do + videoInfoGathered <- readIORef videoInfoRef + let isVideo = R.isVideo videoInfoGathered + let volumeDelta = 0.05 + oldVolume <- GI.Gtk.scaleButtonGetValue volumeButton + keyValue <- GI.Gdk.getEventKeyKeyval eventKey + eventButton <- GI.Gdk.newZeroEventButton + -- Mute Toggle + when (keyValue == GI.Gdk.KEY_m || keyValue == GI.Gdk.KEY_AudioMute) $ do + let newVolume = if oldVolume <= 0.0 then 0.5 else 0.0 + GI.Gtk.scaleButtonSetValue volumeButton newVolume + -- Play/Pause Toggle + when ((keyValue == GI.Gdk.KEY_space || keyValue == GI.Gdk.KEY_AudioPlay) && isVideo) $ + void $ playPauseButtonClickHandler application eventButton + -- Volume Up + when (keyValue == GI.Gdk.KEY_Up || keyValue == GI.Gdk.KEY_AudioRaiseVolume) $ do + let newVolume = if oldVolume >= 1.0 then 1.0 else oldVolume + volumeDelta + GI.Gtk.scaleButtonSetValue volumeButton newVolume + -- Volume Down + when (keyValue == GI.Gdk.KEY_Down || keyValue == GI.Gdk.KEY_AudioLowerVolume) $ do + let newVolume = if oldVolume <= 0.0 then 0.0 else oldVolume - volumeDelta + GI.Gtk.scaleButtonSetValue volumeButton newVolume + -- Show Controls + when (keyValue == GI.Gdk.KEY_c) $ do + eventMotion <- GI.Gdk.newZeroEventMotion + void $ windowMouseMoveHandler application eventMotion + -- Fullscreen Toggle + when (keyValue == GI.Gdk.KEY_f && isVideo) $ do + eventMotion <- GI.Gdk.newZeroEventMotion + void $ windowMouseMoveHandler application eventMotion + void $ fullscreenButtonReleaseHandler application eventButton + return True diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -10,26 +10,35 @@ 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 System.Info 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 GI.GdkPixbuf + +import qualified Records as R +import Constants +import Window +import CommandLine +import Mouse +import Keyboard +import FileChooser +import Seek +import PlayPause +import Fullscreen +import ErrorMessage +import About +import VideoSizeSelector +import Playbin +import ScreensaverAndPowerManagement (disable, enable) +import Utils + import Paths_movie_monad -- Declare Element a type instance of IsVideoOverlay via a newtype wrapper @@ -47,59 +56,119 @@ 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" + fileChooserButton <- builderGetObject GI.Gtk.Button builder "file-chooser-button" + fileChooserButtonLabel <- builderGetObject GI.Gtk.Label builder "file-chooser-button-label" + fileChooserDialog <- builderGetObject GI.Gtk.Dialog builder "file-chooser-dialog" + fileChooserEntry <- builderGetObject GI.Gtk.Entry builder "file-chooser-entry" + fileChooserWidget <- builderGetObject GI.Gtk.FileChooserWidget builder "file-chooser-widget" + fileChooserCancelButton <- builderGetObject GI.Gtk.Button builder "file-chooser-cancel-button" + fileChooserOpenButton <- builderGetObject GI.Gtk.Button builder "file-chooser-open-button" + videoWidgetBox <- builderGetObject GI.Gtk.Box builder "video-widget-box" + bottomControlsGtkBox <- builderGetObject GI.Gtk.Box builder "bottom-controls-gtk-box" seekScale <- builderGetObject GI.Gtk.Scale builder "seek-scale" - onOffSwitch <- builderGetObject GI.Gtk.Switch builder "on-off-switch" + playPauseButton <- builderGetObject GI.Gtk.Button builder "play-pause-button" + playImage <- builderGetObject GI.Gtk.Image builder "play-image" + pauseImage <- builderGetObject GI.Gtk.Image builder "pause-image" volumeButton <- builderGetObject GI.Gtk.VolumeButton builder "volume-button" - desiredVideoWidthComboBox <- builderGetObject GI.Gtk.ComboBoxText builder "desired-video-width-combo-box" + videoWidthSelectionComboBox <- builderGetObject GI.Gtk.ComboBoxText builder "video-width-selection-combo-box" fullscreenButton <- builderGetObject GI.Gtk.Button builder "fullscreen-button" + bufferingSpinner <- builderGetObject GI.Gtk.Spinner builder "buffering-spinner" 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 + logoFile <- getDataFileName "data/movie-monad-logo.svg" + logo <- GI.GdkPixbuf.pixbufNewFromFile (pack logoFile) + GI.Gtk.aboutDialogSetLogo aboutDialog (Just logo) - _ <- GI.Gtk.onFileChooserButtonFileSet fileChooserButton $ - onFileChooserButtonFileSet - playbin - fileChooserButton - volumeButton - isWindowFullScreenRef - desiredVideoWidthComboBox - onOffSwitch - fullscreenButton - drawingArea - window - errorMessageDialog + -- Glade does not allow us to use the response ID nicknames so we programmatically set them here. + GI.Gtk.dialogAddActionWidget fileChooserDialog fileChooserCancelButton (enumToInt32 GI.Gtk.ResponseTypeCancel) + GI.Gtk.dialogAddActionWidget fileChooserDialog fileChooserOpenButton (enumToInt32 GI.Gtk.ResponseTypeOk) - _ <- GI.Gtk.onSwitchStateSet onOffSwitch (onSwitchStateSet playbin) + isWindowFullScreenRef <- newIORef False + mouseMovedLastRef <- newIORef 0 + previousFileNamePathRef <- newIORef "" + videoInfoRef <- newIORef R.defaultVideoInfo - _ <- GI.Gtk.onScaleButtonValueChanged volumeButton (onScaleButtonValueChanged playbin) + let ioRefs = R.IORefs { + R.isWindowFullScreenRef = isWindowFullScreenRef + , R.mouseMovedLastRef = mouseMovedLastRef + , R.previousFileNamePathRef = previousFileNamePathRef + , R.videoInfoRef = videoInfoRef + } - seekScaleHandlerId <- GI.Gtk.onRangeValueChanged seekScale (onRangeValueChanged playbin seekScale) + playbin <- fromJust <$> GI.Gst.elementFactoryMake "playbin" (Just "MultimediaPlayerPlaybin") + maybeGtkSink <- GI.Gst.elementFactoryMake "gtksink" (Just "MultimediaPlayerGtkSink") + videoWidget <- + case maybeGtkSink of + Nothing -> do + putStrLn "Could not create a GtkSink. Please install the bad plugins, version 1.8 or higher, for GStreamer 1." + drawingArea <- GI.Gtk.drawingAreaNew + GI.Gtk.widgetSetName drawingArea invalidVideoWidgetName + GI.Gtk.unsafeCastTo GI.Gtk.Widget drawingArea + Just gtkSink -> + fromJust <$> Data.GI.Base.Properties.getObjectPropertyObject gtkSink "widget" GI.Gtk.Widget - _ <- GI.GLib.timeoutAddSeconds GI.GLib.PRIORITY_DEFAULT 1 (updateSeekScale playbin seekScale seekScaleHandlerId) + Data.GI.Base.Properties.setObjectPropertyObject playbin "video-sink" maybeGtkSink + Data.GI.Base.Properties.setObjectPropertyBool playbin "force-aspect-ratio" True + GI.Gtk.boxPackStart videoWidgetBox videoWidget True True 0 + GI.Gtk.widgetSetHexpand videoWidget True + GI.Gtk.widgetSetVexpand videoWidget True + GI.Gtk.widgetSetSensitive videoWidget True - _ <- GI.Gtk.onComboBoxChanged desiredVideoWidthComboBox $ - onComboBoxChanged fileChooserButton desiredVideoWidthComboBox drawingArea window + playbinBus <- GI.Gst.elementGetBus playbin - _ <- GI.Gtk.onWidgetButtonReleaseEvent fullscreenButton - (onFullscreenButtonRelease isWindowFullScreenRef desiredVideoWidthComboBox fileChooserButton window) + let guiObjects = R.GuiObjects { + R.window = window + , R.fileChooserButton = fileChooserButton + , R.fileChooserButtonLabel = fileChooserButtonLabel + , R.fileChooserDialog = fileChooserDialog + , R.fileChooserEntry = fileChooserEntry + , R.fileChooserWidget = fileChooserWidget + , R.fileChooserCancelButton = fileChooserCancelButton + , R.fileChooserOpenButton = fileChooserOpenButton + , R.videoWidget = videoWidget + , R.bottomControlsGtkBox = bottomControlsGtkBox + , R.seekScale = seekScale + , R.playPauseButton = playPauseButton + , R.playImage = playImage + , R.pauseImage = pauseImage + , R.volumeButton = volumeButton + , R.videoWidthSelectionComboBox = videoWidthSelectionComboBox + , R.fullscreenButton = fullscreenButton + , R.bufferingSpinner = bufferingSpinner + , R.errorMessageDialog = errorMessageDialog + , R.aboutButton = aboutButton + , R.aboutDialog = aboutDialog + } - _ <- GI.Gtk.onWidgetWindowStateEvent window (onWidgetWindowStateEvent isWindowFullScreenRef) + let application = R.Application { + R.guiObjects = guiObjects + , R.ioRefs = ioRefs + , R.playbin = playbin + , R.playbinBus = playbinBus + } - _ <- GI.Gtk.onWidgetButtonReleaseEvent aboutButton (onAboutButtonRelease aboutDialog) + addWindowHandlers application [playVideoFromCommandLineIfNeeded] + addPlaybinHandler application + addFileChooserHandlers application + addPlayPauseButtonClickHandler application + addSeekHandlers application + addVideoSizeSelectorHandler application + addFullscreenButtonReleaseHandler application + addWindowMouseMoveHandlers application + addAboutHandler application + addKeyboardEventHandler application + addErrorMessageDialogHandler application - _ <- GI.Gtk.onWidgetDestroy window (onWindowDestroy playbin) + let operatingSystem = System.Info.os + screenAndPowerManagementActions <- ScreensaverAndPowerManagement.disable operatingSystem GI.Gtk.widgetShowAll window GI.Gtk.main + ScreensaverAndPowerManagement.enable operatingSystem screenAndPowerManagementActions + builderGetObject :: (GI.GObject.GObject b, GI.Gtk.IsBuilder a) => (Data.GI.Base.ManagedPtr b -> b) -> @@ -109,284 +178,3 @@ 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 diff --git a/src/Mouse.hs b/src/Mouse.hs new file mode 100644 --- /dev/null +++ b/src/Mouse.hs @@ -0,0 +1,69 @@ +{- + Movie Monad + (C) 2017 David lettier + lettier.com +-} + +module Mouse where + +import Control.Monad +import Data.Maybe +import Data.Text +import Data.IORef +import Data.Time.Clock.POSIX +import qualified GI.Gdk +import qualified GI.Gtk + +import qualified Records as R + +addWindowMouseMoveHandlers :: R.Application -> IO () +addWindowMouseMoveHandlers + application@R.Application { + R.guiObjects = R.GuiObjects { + R.videoWidget = videoWidget + , R.seekScale = seekScale + } + } + = + void (GI.Gtk.onWidgetMotionNotifyEvent videoWidget (windowMouseMoveHandler application)) >> + void (GI.Gtk.onWidgetMotionNotifyEvent seekScale (windowMouseMoveHandler application)) + +windowMouseMoveHandler :: + R.Application -> + GI.Gdk.EventMotion -> + IO Bool +windowMouseMoveHandler + R.Application { + R.guiObjects = R.GuiObjects { + R.window = window + , R.fileChooserButton = fileChooserButton + , R.bottomControlsGtkBox = bottomControlsGtkBox + } + , R.ioRefs = R.IORefs { + R.isWindowFullScreenRef = isWindowFullScreenRef + , R.mouseMovedLastRef = mouseMovedLastRef + } + } + _ + = do + isWindowFullScreen <- readIORef isWindowFullScreenRef + unless isWindowFullScreen $ GI.Gtk.widgetShow fileChooserButton + GI.Gtk.widgetShow bottomControlsGtkBox + setCursor window Nothing + timeNow <- getPOSIXTime + atomicWriteIORef mouseMovedLastRef (round timeNow) + return False + +setCursor :: GI.Gtk.Window -> Maybe Text -> IO () +setCursor window Nothing = + fromJust <$> GI.Gtk.widgetGetWindow window >>= + flip GI.Gdk.windowSetCursor (Nothing :: Maybe GI.Gdk.Cursor) +setCursor window (Just cursorType) = do + gdkWindow <- fromJust <$> GI.Gtk.widgetGetWindow window + maybeCursor <- makeCursor gdkWindow cursorType + GI.Gdk.windowSetCursor gdkWindow maybeCursor + +makeCursor :: GI.Gdk.Window -> Text -> IO (Maybe GI.Gdk.Cursor) +makeCursor window cursorType = + GI.Gdk.windowGetDisplay window >>= + flip GI.Gdk.cursorNewFromName cursorType diff --git a/src/PlayPause.hs b/src/PlayPause.hs new file mode 100644 --- /dev/null +++ b/src/PlayPause.hs @@ -0,0 +1,81 @@ +{- + Movie Monad + (C) 2017 David lettier + lettier.com +-} + +{-# LANGUAGE OverloadedStrings #-} + +module PlayPause where + +import Control.Monad +import Data.Text +import qualified GI.Gdk +import qualified GI.Gtk +import qualified GI.Gst + +import qualified Records as R + +addPlayPauseButtonClickHandler :: R.Application -> IO () +addPlayPauseButtonClickHandler + application@R.Application { + R.guiObjects = R.GuiObjects { + R.playPauseButton = playPauseButton + } + } + = + void $ GI.Gtk.onWidgetButtonReleaseEvent playPauseButton (playPauseButtonClickHandler application) + +playPauseButtonClickHandler :: + R.Application -> + GI.Gdk.EventButton -> + IO Bool +playPauseButtonClickHandler + R.Application { + R.guiObjects = R.GuiObjects { + R.playPauseButton = playPauseButton + , R.playImage = playImage + , R.pauseImage = pauseImage + } + , R.playbin = playbin + } + _ + = do + isPlaying <- isPlayPauseButtonPlaying playPauseButton + if isPlaying + then do + setPlayPauseButton playPauseButton playImage pauseImage False + void $ GI.Gst.elementSetState playbin GI.Gst.StatePaused + else do + setPlayPauseButton playPauseButton playImage pauseImage True + void $ GI.Gst.elementSetState playbin GI.Gst.StatePlaying + return False + +setPlayPauseButton :: + GI.Gtk.Button -> + GI.Gtk.Image -> + GI.Gtk.Image -> + Bool -> + IO () +setPlayPauseButton playPauseButton _ pauseImage True = do + GI.Gtk.buttonSetImage playPauseButton (Just pauseImage) + GI.Gtk.widgetSetTooltipText playPauseButton (Just "Click to pause") +setPlayPauseButton playPauseButton playImage _ False = do + GI.Gtk.buttonSetImage playPauseButton (Just playImage) + GI.Gtk.widgetSetTooltipText playPauseButton (Just "Click to play") + +isPlayPauseButtonPlaying :: + GI.Gtk.Button -> + IO Bool +isPlayPauseButtonPlaying playPauseButton = + GI.Gtk.buttonGetImage playPauseButton >>= getImage >>= getName >>= getMatch + where + getImage :: Maybe GI.Gtk.Widget -> IO (Maybe GI.Gtk.Image) + getImage Nothing = return Nothing + getImage (Just widget) = GI.Gtk.castTo GI.Gtk.Image widget + getName :: Maybe GI.Gtk.Image -> IO (Maybe Text) + getName Nothing = return Nothing + getName (Just image) = GI.Gtk.getImageStock image + getMatch :: Maybe Text -> IO Bool + getMatch Nothing = return False + getMatch (Just text) = return ("gtk-media-pause" == text) diff --git a/src/Playbin.hs b/src/Playbin.hs new file mode 100644 --- /dev/null +++ b/src/Playbin.hs @@ -0,0 +1,122 @@ +{- + Movie Monad + (C) 2017 David lettier + lettier.com +-} + +{-# LANGUAGE OverloadedStrings #-} + +module Playbin where + +import Control.Monad +import Data.Text +import Data.GI.Base.Properties +import GI.GLib +import qualified GI.Gtk +import qualified GI.Gst + +import qualified Records as R +import Window +import PlayPause +import ErrorMessage +import Uri + +addPlaybinHandler :: R.Application -> IO () +addPlaybinHandler + R.Application { + R.guiObjects = guiObjects@R.GuiObjects { + R.volumeButton = volumeButton + } + , R.playbin = playbin + , R.playbinBus = playbinBus + } + = + void( + GI.Gst.busAddWatch playbinBus GI.GLib.PRIORITY_DEFAULT ( + pipelineBusMessageHandler + guiObjects + playbin + ) + ) >> + void ( + GI.Gtk.onScaleButtonValueChanged volumeButton (volumeButtonValueChangedHandler playbin) + ) + +pipelineBusMessageHandler :: + R.GuiObjects -> + GI.Gst.Element -> + GI.Gst.Bus -> + GI.Gst.Message -> + IO Bool +pipelineBusMessageHandler + guiObjects@R.GuiObjects { + R.seekScale = seekScale + , R.fileChooserEntry = fileChooserEntry + , R.fileChooserButtonLabel = fileChooserButtonLabel + , R.volumeButton = volumeButton + , R.errorMessageDialog = errorMessageDialog + , R.bufferingSpinner = bufferingSpinner + , R.playPauseButton = playPauseButton + } + 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 + Prelude.mapM_ print [text, "\n", gErrorText] + GI.Gtk.entrySetText fileChooserEntry "" + GI.Gtk.labelSetText fileChooserButtonLabel "Open" + _ <- GI.Gst.elementSetState playbin GI.Gst.StateNull + setPlaybinUriAndVolume playbin "" volumeButton + resetWindow guiObjects + 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 () + return True + +volumeButtonValueChangedHandler :: + GI.Gst.Element -> + Double -> + IO () +volumeButtonValueChangedHandler playbin volume = + void $ Data.GI.Base.Properties.setObjectPropertyDouble playbin "volume" volume + +setPlaybinUriAndVolume :: + GI.Gst.Element -> + Prelude.String -> + GI.Gtk.VolumeButton -> + IO () +setPlaybinUriAndVolume playbin fileName volumeButton = do + uri <- addUriSchemeIfNone fileName + volume <- GI.Gtk.scaleButtonGetValue volumeButton + Data.GI.Base.Properties.setObjectPropertyDouble playbin "volume" volume + Data.GI.Base.Properties.setObjectPropertyString playbin "uri" (Just $ pack uri) diff --git a/src/Records.hs b/src/Records.hs new file mode 100644 --- /dev/null +++ b/src/Records.hs @@ -0,0 +1,76 @@ +{- + Movie Monad + (C) 2017 David lettier + lettier.com +-} + +module Records where + +import Data.IORef +import Data.Text +import qualified GI.Gtk +import qualified GI.Gst + +data VideoInfo = VideoInfo { + uri :: Prelude.String + , isLocalFile :: Bool + , isVideo :: Bool + , isSeekable :: Bool + , videoWidth :: Int + , videoHeight :: Int + } + +defaultVideoInfo :: VideoInfo +defaultVideoInfo = VideoInfo { + uri = "" + , isLocalFile = False + , isVideo = False + , isSeekable = False + , videoWidth = 800 + , videoHeight = 600 + } + +data GuiObjects = GuiObjects { + window :: GI.Gtk.Window + , fileChooserButton :: GI.Gtk.Button + , fileChooserButtonLabel :: GI.Gtk.Label + , fileChooserDialog :: GI.Gtk.Dialog + , fileChooserEntry :: GI.Gtk.Entry + , fileChooserWidget :: GI.Gtk.FileChooserWidget + , fileChooserCancelButton :: GI.Gtk.Button + , fileChooserOpenButton :: GI.Gtk.Button + , videoWidget :: GI.Gtk.Widget + , bottomControlsGtkBox :: GI.Gtk.Box + , seekScale :: GI.Gtk.Scale + , playPauseButton :: GI.Gtk.Button + , playImage :: GI.Gtk.Image + , pauseImage :: GI.Gtk.Image + , volumeButton :: GI.Gtk.VolumeButton + , videoWidthSelectionComboBox :: GI.Gtk.ComboBoxText + , fullscreenButton :: GI.Gtk.Button + , bufferingSpinner :: GI.Gtk.Spinner + , errorMessageDialog :: GI.Gtk.MessageDialog + , aboutButton :: GI.Gtk.Button + , aboutDialog :: GI.Gtk.AboutDialog + } + +data IORefs = IORefs { + isWindowFullScreenRef :: IORef Bool + , mouseMovedLastRef :: IORef Integer + , previousFileNamePathRef :: IORef Data.Text.Text + , videoInfoRef :: IORef VideoInfo + } + +data ScreensaverAndPowerManagementActions = ScreensaverAndPowerManagementActions { + disabledPowerManagement :: Bool + , disabledXScreensaver :: Bool + , disabledCinnamonScreensaver :: Bool + , disabledGnomeScreensaver :: Bool + } + +data Application = Application { + guiObjects :: GuiObjects + , ioRefs :: IORefs + , playbin :: GI.Gst.Element + , playbinBus :: GI.Gst.Bus + } diff --git a/src/ScreensaverAndPowerManagement.hs b/src/ScreensaverAndPowerManagement.hs new file mode 100644 --- /dev/null +++ b/src/ScreensaverAndPowerManagement.hs @@ -0,0 +1,108 @@ +{- + Movie Monad + (C) 2017 David lettier + lettier.com +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module ScreensaverAndPowerManagement where + +import System.Process +import Control.Monad +import Data.Text + +import qualified Records as R (ScreensaverAndPowerManagementActions(..)) +import Utils (safeRunProcessGetOutput, linuxProcessIsRunning, spawnLinuxProcessAndDisown) + +disable :: String -> IO R.ScreensaverAndPowerManagementActions +disable "linux" = do + disabledPowerManagement <- disablePowerManagement + disabledXScreensaver <- disableXScreensaver + disabledCinnamonScreensaver <- disableCinnamonScreensaver + disabledGnomeScreensaver <- disableGnomeScreensaver + return R.ScreensaverAndPowerManagementActions { + R.disabledPowerManagement = disabledPowerManagement + , R.disabledXScreensaver = disabledXScreensaver + , R.disabledCinnamonScreensaver = disabledCinnamonScreensaver + , R.disabledGnomeScreensaver = disabledGnomeScreensaver + } +disable _ = + return R.ScreensaverAndPowerManagementActions { + R.disabledPowerManagement = False + , R.disabledXScreensaver = False + , R.disabledCinnamonScreensaver = False + , R.disabledGnomeScreensaver = False + } + +enable :: String -> R.ScreensaverAndPowerManagementActions -> IO () +enable + "linux" + R.ScreensaverAndPowerManagementActions { + R.disabledPowerManagement = disabledPowerManagement + , R.disabledXScreensaver = disabledXScreensaver + , R.disabledCinnamonScreensaver = disabledCinnamonScreensaver + , R.disabledGnomeScreensaver = disabledGnomeScreensaver + } + = do + when disabledPowerManagement enablePowerManagement + when disabledXScreensaver enableXScreensaver + when disabledCinnamonScreensaver enableCinnamonScreensaver + when disabledGnomeScreensaver enableGnomeScreensaver + return () +enable _ _ = return () + +disablePowerManagement :: IO Bool +disablePowerManagement = do + (_, out, _) <- safeRunProcessGetOutput "xset" ["-q"] + let isEnabled = + Data.Text.isInfixOf "dpms is enabled" $ + Data.Text.toLower $ + Data.Text.pack out + if isEnabled + then do + _ <- System.Process.spawnCommand "sleep 1; xset -dpms s off" + return True + else return False + +enablePowerManagement :: IO () +enablePowerManagement = + void $ + System.Process.spawnCommand "sleep 1; xset +dpms s on" + +disableXScreensaver :: IO Bool +disableXScreensaver = + disableScreensaver + "xscreensaver" + "xscreensaver-command --exit" + +enableXScreensaver :: IO () +enableXScreensaver = spawnLinuxProcessAndDisown "xscreensaver -no-splash" + +disableCinnamonScreensaver :: IO Bool +disableCinnamonScreensaver = + disableScreensaver + "cinnamon-screensaver" + "cinnamon-screensaver-command --exit" + +enableCinnamonScreensaver :: IO () +enableCinnamonScreensaver = spawnLinuxProcessAndDisown "cinnamon-screensaver" + +disableGnomeScreensaver :: IO Bool +disableGnomeScreensaver = + disableScreensaver + "gnome-screensaver" + "gnome-screensaver-command --exit" + +enableGnomeScreensaver :: IO () +enableGnomeScreensaver = spawnLinuxProcessAndDisown "gnome-screensaver" + +disableScreensaver :: String -> String -> IO Bool +disableScreensaver processName disableCommand = do + isRunning <- linuxProcessIsRunning processName + if isRunning + then do + spawnLinuxProcessAndDisown disableCommand + return True + else return False diff --git a/src/Seek.hs b/src/Seek.hs new file mode 100644 --- /dev/null +++ b/src/Seek.hs @@ -0,0 +1,93 @@ +{- + Movie Monad + (C) 2017 David lettier + lettier.com +-} + +module Seek where + +import Control.Monad +import Data.IORef +import Data.Int +import Data.Time.Clock.POSIX +import Data.GI.Base.Signals +import GI.GLib +import GI.GObject +import qualified GI.Gtk +import qualified GI.Gst + +import qualified Records as R + +addSeekHandlers :: R.Application -> IO () +addSeekHandlers + R.Application { + R.guiObjects = R.GuiObjects { + R.seekScale = seekScale + } + , R.ioRefs = R.IORefs { + R.videoInfoRef = videoInfoRef + } + , R.playbin = playbin + } + = do + seekScaleHandlerId <- GI.Gtk.onRangeValueChanged seekScale ( + onRangeValueChanged + playbin + seekScale + videoInfoRef + ) + void ( + GI.GLib.timeoutAdd GI.GLib.PRIORITY_DEFAULT 41 ( + updateSeekScale + playbin + seekScale + seekScaleHandlerId + ) + ) + +seekRequestLastDeltaThreshold :: R.VideoInfo -> POSIXTime +seekRequestLastDeltaThreshold R.VideoInfo { R.isLocalFile = True } = 0.0 +seekRequestLastDeltaThreshold R.VideoInfo { R.isLocalFile = False } = 0.0 + +onRangeValueChanged :: + GI.Gst.Element -> + GI.Gtk.Scale -> + IORef R.VideoInfo -> + IO () +onRangeValueChanged + playbin + seekScale + videoInfoRef + = 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 + videoInfoGathered <- readIORef videoInfoRef + -- When playing over a network (not local), + -- sending too many asynchronous seek requests will cause GStreamer to error. + -- Block until this seek request finishes which will block the main GTK main thread. + -- Note that by blocking here, the seek scale will not slide. + -- The user will have to point and click on the scale track. + unless (R.isLocalFile videoInfoGathered) $ void $ GI.Gst.elementGetState playbin GI.Gst.CLOCK_TIME_NONE + +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 + when (couldQueryDuration && couldQueryPosition && duration > 0) $ do + let percentage = 100.0 * (fromIntegral position / fromIntegral duration :: Double) + GI.GObject.signalHandlerBlock seekScale seekScaleHandlerId + GI.Gtk.rangeSetValue seekScale percentage + GI.GObject.signalHandlerUnblock seekScale seekScaleHandlerId + return True diff --git a/src/Uri.hs b/src/Uri.hs new file mode 100644 --- /dev/null +++ b/src/Uri.hs @@ -0,0 +1,66 @@ +{- + Movie Monad + (C) 2017 David lettier + lettier.com +-} + +{-# LANGUAGE OverloadedStrings #-} + +module Uri where + +import System.FilePath +import Filesystem +import Filesystem.Path.CurrentOS +import Data.Text + +removeFileUriScheme :: Prelude.String -> Prelude.String +removeFileUriScheme str = + if hasFileUriScheme str + then Data.Text.unpack $ Data.Text.replace "file://" "" uri + else Data.Text.unpack uri + where + uri :: Data.Text.Text + uri = Data.Text.pack str + +hasFileUriScheme :: Prelude.String -> Bool +hasFileUriScheme = hasUriScheme "file://" + +hasHttpUriScheme :: Prelude.String -> Bool +hasHttpUriScheme str = isHttp || isHttps + where + isHttp :: Bool + isHttp = hasUriScheme "http://" str + isHttps :: Bool + isHttps = hasUriScheme "https://" str + +hasUriScheme :: Prelude.String -> Prelude.String -> Bool +hasUriScheme scheme uri = toLower' scheme `Data.Text.isPrefixOf` toLower' uri + where + toLower' :: Prelude.String -> Text + toLower' = Data.Text.toLower . Data.Text.pack + +addUriSchemeIfNone :: Prelude.String -> IO Prelude.String +addUriSchemeIfNone filePathName = + isLocalFile filePathName >>= + \ local -> + return $ + if local + then if hasFileUriScheme filePathName then filePathName else "file://" ++ filePathName + else if hasHttpUriScheme filePathName then filePathName else "http://" ++ filePathName + +isLocalFile :: Prelude.String -> IO Bool +isLocalFile = Filesystem.isFile . Filesystem.Path.CurrentOS.fromText . Data.Text.pack . removeFileUriScheme + +toAbsoluteUri :: String -> IO String +toAbsoluteUri uri = do + cwd <- getWorkingDirectory + let cwd' = case toText cwd of + Right x -> x + Left y -> y + isLocal <- isLocalFile uri + if not isLocal + then return uri + else + if isRelative uri + then return $ normalise $ combine (Data.Text.unpack cwd') uri + else return uri diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,58 @@ +{- + Movie Monad + (C) 2017 David lettier + lettier.com +-} + +{-# LANGUAGE ScopedTypeVariables #-} + +module Utils where + +import System.Exit +import System.Process +import System.FilePath +import Control.Monad +import Control.Exception +import Data.List +import Data.Text +import Data.Int +import qualified GI.Gtk + +fileNameFromFilePathName :: Data.Text.Text -> Data.Text.Text +fileNameFromFilePathName = Data.Text.pack . System.FilePath.takeFileName . Data.Text.unpack + +enumToInt32 :: (Enum a, Ord a) => a -> Int32 +enumToInt32 enum = fromIntegral (fromEnum enum) :: Int32 + +isTextEmpty :: Data.Text.Text -> Bool +isTextEmpty = Data.Text.null . Data.Text.strip + +getSelectedVideoWidth :: GI.Gtk.ComboBoxText -> IO Int +getSelectedVideoWidth = fmap (\ x -> read (Data.Text.unpack x) :: Int) . GI.Gtk.comboBoxTextGetActiveText + +linuxProcessIsRunning :: String -> IO Bool +linuxProcessIsRunning processName = do + (_, out, _) <- safeRunProcessGetOutput "pgrep" ["-f", processName] + return (not $ Data.List.null out) + +spawnLinuxProcessAndDisown :: String -> IO () +spawnLinuxProcessAndDisown processCommand = + void $ + System.Process.spawnCommand + ( + "nohup " + ++ processCommand + ++ " /dev/null & disown" + ) + +safeRunProcessGetOutput :: String -> [String] -> IO (System.Exit.ExitCode, String, String) +safeRunProcessGetOutput processName args = + catch ( + readProcessWithExitCode + processName + args + "" + ) (\ (e :: Control.Exception.IOException) -> + print e >> + return (ExitFailure 1, "", "") + ) diff --git a/src/VideoInfo.hs b/src/VideoInfo.hs new file mode 100644 --- /dev/null +++ b/src/VideoInfo.hs @@ -0,0 +1,76 @@ +{- + Movie Monad + (C) 2017 David lettier + lettier.com +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module VideoInfo where + +import System.Exit +import Text.Read +import Data.Maybe +import Data.Text +import Data.IORef + +import qualified Records as R +import Uri +import Utils + +getVideoInfoRaw :: Prelude.String -> IO (Maybe Prelude.String) +getVideoInfoRaw uri = do + (code, out, _) <- safeRunProcessGetOutput "gst-discoverer-1.0" [uri, "-v"] + if code == System.Exit.ExitSuccess + then return (Just out) + else return Nothing + +getVideoInfo :: IORef R.VideoInfo -> Prelude.String -> IO R.VideoInfo +getVideoInfo videoInfoRef filePathName = do + videoInfoGathered <- readIORef videoInfoRef + uri <- addUriSchemeIfNone filePathName + cacheDo (R.uri videoInfoGathered == uri) videoInfoGathered uri + where + widthField :: Data.Text.Text + widthField = "width: " + heightField :: Data.Text.Text + heightField = "height: " + seekableField :: Data.Text.Text + seekableField = "seekable: " + cacheDo :: Bool -> R.VideoInfo -> Prelude.String -> IO R.VideoInfo + cacheDo True videoInfoGathered _ = return videoInfoGathered + cacheDo False _ uri = do + videoInfoRaw <- getVideoInfoRaw uri + processVideoInfoRaw videoInfoRaw uri + processVideoInfoRaw :: Maybe Prelude.String -> Prelude.String -> IO R.VideoInfo + processVideoInfoRaw Nothing _ = do + let videoInfoGathered = R.defaultVideoInfo + atomicWriteIORef videoInfoRef videoInfoGathered + return videoInfoGathered + processVideoInfoRaw (Just str) uri = do + let text = Data.Text.toLower $ Data.Text.pack str + let textLines = Data.Text.lines text + let videoInfoGathered = R.VideoInfo { + R.uri = uri + , R.isLocalFile = hasFileUriScheme uri + , R.isVideo = "video: video/" `Data.Text.isInfixOf` text + , R.isSeekable = "yes" == getField seekableField textLines + , R.videoWidth = getDimension R.videoWidth widthField textLines + , R.videoHeight = getDimension R.videoHeight heightField textLines + } + atomicWriteIORef videoInfoRef videoInfoGathered + return videoInfoGathered + getDimension :: (R.VideoInfo -> Int) -> Data.Text.Text -> [Data.Text.Text] -> Int + getDimension f field lines' = fromMaybe ( + f R.defaultVideoInfo + ) (readMaybe (Data.Text.unpack $ getField field lines') :: Maybe Int) + getField :: Data.Text.Text -> [Data.Text.Text] -> Data.Text.Text + getField field = + Prelude.foldl (\ acc l -> + if not $ Data.Text.null acc + then acc + else if field `Data.Text.isInfixOf` l + then Data.Text.replace field "" $ Data.Text.strip l + else "" + ) "" diff --git a/src/VideoSizeSelector.hs b/src/VideoSizeSelector.hs new file mode 100644 --- /dev/null +++ b/src/VideoSizeSelector.hs @@ -0,0 +1,54 @@ +{- + Movie Monad + (C) 2017 David lettier + lettier.com +-} + +module VideoSizeSelector where + +import Control.Monad +import Data.Text +import qualified GI.Gtk + +import qualified Records as R +import Window +import VideoInfo +import Utils + +addVideoSizeSelectorHandler :: R.Application -> IO () +addVideoSizeSelectorHandler + application@R.Application { + R.guiObjects = R.GuiObjects { + R.videoWidthSelectionComboBox = videoWidthSelectionComboBox + } + } + = void ( + GI.Gtk.onComboBoxChanged + videoWidthSelectionComboBox + (videoSizeSelectionHandler application) + ) + +videoSizeSelectionHandler :: + R.Application -> + IO () +videoSizeSelectionHandler + R.Application { + R.guiObjects = guiObjects@R.GuiObjects { + R.window = window + , R.fileChooserButton = fileChooserButton + , R.videoWidget = videoWidget + , R.videoWidthSelectionComboBox = videoWidthSelectionComboBox + , R.fileChooserEntry = fileChooserEntry + } + , R.ioRefs = R.IORefs { + R.videoInfoRef = videoInfoRef + } + } + = do + filePathName <- Data.Text.unpack <$> GI.Gtk.entryGetText fileChooserEntry + videoWidthSelection <- getSelectedVideoWidth videoWidthSelectionComboBox + retrievedVideoInfo <- getVideoInfo videoInfoRef filePathName + maybeWindowSize <- calculateWindowSize videoWidthSelection retrievedVideoInfo + case maybeWindowSize of + Nothing -> resetWindow guiObjects + Just (width, height) -> setWindowSize width height fileChooserButton videoWidget window diff --git a/src/Window.hs b/src/Window.hs new file mode 100644 --- /dev/null +++ b/src/Window.hs @@ -0,0 +1,195 @@ +{- + Movie Monad + (C) 2017 David lettier + lettier.com +-} + +{-# LANGUAGE OverloadedStrings #-} + +module Window where + +import GHC.Word +import Control.Monad +import Data.Int +import Data.IORef +import Data.Time.Clock.POSIX +import GI.GLib +import qualified GI.Gdk +import qualified GI.Gtk +import qualified GI.Gst + +import qualified Records as R +import Constants +import Mouse +import PlayPause +import Utils + +addWindowHandlers :: R.Application -> [R.Application -> IO ()] -> IO () +addWindowHandlers + application@R.Application { + R.guiObjects = R.GuiObjects { + R.window = window + , R.videoWidget = videoWidget + } + , R.ioRefs = R.IORefs { + R.isWindowFullScreenRef = isWindowFullScreenRef + } + , R.playbin = playbin + } + functionsToRunOnWindowRealized + = + void ( + GI.Gtk.onWidgetRealize videoWidget ( + windowRealizedHandler + application + functionsToRunOnWindowRealized + ) + ) >> + void ( + GI.Gtk.onWidgetWindowStateEvent window (widgetWindowStateEventHandler isWindowFullScreenRef) + ) >> + void ( + GI.Gtk.onWidgetDestroy window (windowDestroyHandler playbin) + ) >> + void ( + GI.GLib.timeoutAddSeconds GI.GLib.PRIORITY_DEFAULT 1 (hideOnScreenControls application) + ) + +windowRealizedHandler :: + R.Application -> + [R.Application -> IO ()] -> + GI.Gtk.WidgetRealizeCallback +windowRealizedHandler + application@R.Application { + R.guiObjects = guiObjects@R.GuiObjects { + R.videoWidget = videoWidget + , R.seekScale = seekScale + } + } + functionsToRunOnWindowRealized + = do + let eventMask = enumToInt32 GI.Gdk.EventMaskAllEventsMask + GI.Gtk.widgetAddEvents videoWidget eventMask + GI.Gtk.widgetAddEvents seekScale eventMask + resetWindow guiObjects + mapM_ (\ f -> f application) functionsToRunOnWindowRealized + +widgetWindowStateEventHandler :: + IORef Bool -> + GI.Gdk.EventWindowState -> + IO Bool +widgetWindowStateEventHandler isWindowFullScreenRef eventWindowState = do + windowStates <- GI.Gdk.getEventWindowStateNewWindowState eventWindowState + let isWindowFullScreen = Prelude.foldl (\ acc x -> + acc || GI.Gdk.WindowStateFullscreen == x + ) False windowStates + atomicWriteIORef isWindowFullScreenRef isWindowFullScreen + return True + +windowDestroyHandler :: + GI.Gst.Element -> + IO () +windowDestroyHandler playbin = do + _ <- GI.Gst.elementSetState playbin GI.Gst.StateNull + _ <- GI.Gst.objectUnref playbin + GI.Gtk.mainQuit + +hideOnScreenControls :: + R.Application -> + IO Bool +hideOnScreenControls + R.Application { + R.guiObjects = R.GuiObjects { + R.window = window + , R.fileChooserButton = fileChooserButton + , R.bottomControlsGtkBox = bottomControlsGtkBox + } + , R.ioRefs = R.IORefs { + R.videoInfoRef = videoInfoRef + , R.mouseMovedLastRef = mouseMovedLastRef + } + , R.playbin = playbin + } + = do + isVideo <- R.isVideo <$> readIORef videoInfoRef + mouseMovedLast <- readIORef mouseMovedLastRef + timeNow <- fmap round getPOSIXTime + (_, playBinState, _) <- GI.Gst.elementGetState playbin (fromIntegral GI.Gst.MSECOND :: GHC.Word.Word64) + let isPlaying = GI.Gst.StatePlaying == playBinState + let delta = timeNow - mouseMovedLast + when (isPlaying && isVideo && delta >= hideOnScreenControlsInterval) $ do + GI.Gtk.widgetHide fileChooserButton + GI.Gtk.widgetHide bottomControlsGtkBox + setCursor window (Just "none") + atomicWriteIORef mouseMovedLastRef timeNow + return True + +calculateWindowSize :: Int -> R.VideoInfo -> IO (Maybe (Int32, Int32)) +calculateWindowSize videoWidthSelection retrievedVideoInfo = + widthHeightToDouble retrievedVideoInfo >>= + ratio >>= + windowSize + where + widthHeightToDouble :: R.VideoInfo -> IO (Maybe Double, Maybe Double) + widthHeightToDouble R.VideoInfo { R.isVideo = False } = return (Nothing, Nothing) + widthHeightToDouble R.VideoInfo { R.videoWidth = w, R.videoHeight = h } = + return (Just $ fromIntegral w :: Maybe Double, Just $ fromIntegral h :: Maybe Double) + 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 videoWidthSelection :: Int32 + , round ((fromIntegral videoWidthSelection :: Double) * ratio') :: Int32 + ) + ) + +setWindowSize :: + Int32 -> + Int32 -> + GI.Gtk.Button -> + GI.Gtk.Widget -> + GI.Gtk.Window -> + IO () +setWindowSize width height fileChooserButton videoWidget window = do + GI.Gtk.setWidgetWidthRequest fileChooserButton width + GI.Gtk.setWidgetWidthRequest videoWidget width + GI.Gtk.setWidgetHeightRequest videoWidget height + GI.Gtk.setWidgetWidthRequest window width + GI.Gtk.setWidgetHeightRequest window height + GI.Gtk.windowResize window width (if height <= 0 then 1 else height) + +resetWindow :: + R.GuiObjects -> + IO () +resetWindow + R.GuiObjects { + R.window = window + , R.fileChooserButton = fileChooserButton + , R.videoWidget = videoWidget + , R.seekScale = seekScale + , R.playPauseButton = playPauseButton + , R.videoWidthSelectionComboBox = videoWidthSelectionComboBox + , R.fullscreenButton = fullscreenButton + , R.playImage = playImage + , R.pauseImage = pauseImage + , R.bottomControlsGtkBox = bottomControlsGtkBox + } + = do + videoWidthSelection <- getSelectedVideoWidth videoWidthSelectionComboBox + let width = fromIntegral videoWidthSelection :: Int32 + GI.Gtk.windowUnfullscreen window + GI.Gtk.widgetHide videoWidget + GI.Gtk.widgetHide seekScale + GI.Gtk.widgetHide playPauseButton + GI.Gtk.widgetHide fullscreenButton + GI.Gtk.widgetShow fileChooserButton + GI.Gtk.widgetShow bottomControlsGtkBox + GI.Gtk.widgetShow videoWidthSelectionComboBox + setCursor window Nothing + setPlayPauseButton playPauseButton playImage pauseImage False + setWindowSize width 0 fileChooserButton videoWidget window diff --git a/src/data/gui.glade b/src/data/gui.glade --- a/src/data/gui.glade +++ b/src/data/gui.glade @@ -1,66 +1,165 @@ - + - + + + + + + True False gtk-dialog-question - - 100 - 1 - 10 + + gtk-cancel + True + True + True + True + True + + gtk-open + True + True + True + True + True + True False gtk-fullscreen - + + True False + gtk-media-pause + + + True + False + gtk-media-play + + + 100 + 1 + 10 + + + True Movie Monad center - applications-multimedia + movie-monad-icon.png center - + True False vertical - + True False True True vertical - + 800 True True - False - Select a video file. + True + True + Open a video file start True - False - Movie Monad + half + right + True + + + True + False + + + True + False + Open + fill + end + True + + + True + True + 0 + + + + + True + False + gtk-open + + + False + False + end + 2 + + + + False - True + False 0 - + True - False True - False + True True True + vertical + + + True @@ -69,163 +168,209 @@ - + True - True + False end - 5 - 5 - True - adjustment1 - True - 100 - 0 - -1 - False - left - - - False - False - 2 - - - - - True - True - 0 - - - - - True - False - end - 5 - True - - - True - True - Toggle on to play. Toggle off to pause. - 5 - - - False - False - 0 - - - - - True - True - True - False - True - False - 5 - 5 - none - 0.5 - button - audio-volume-muted-symbolic + vertical + bottom + + + True + True + False + end + 5 + 5 + True + seek-scale-adjustment + True + 100 + 0 + -1 + False + left + + + False + False + 0 + + + + + True + False + end + 5 + 5 + True + + + True + True + True + Click to play + 5 + 5 + play-image + True + + + False + True + 0 + + + + + True + True + True + False + True + False + 5 + 5 + half + vertical + 0.5 + button + audio-volume-muted-symbolic audio-volume-high-symbolic audio-volume-low-symbolic audio-volume-medium-symbolic - - - True - True - center - center - none - - - - - True - True - center - center - none + + + True + True + center + center + none + + + + + True + True + center + center + none + + + + + False + False + 1 + + + + + True + True + False + Set the video width + 5 + 5 + 1 + False + 800 + + 320 + 800 + 1024 + 1152 + 1280 + 1360 + 1366 + 1440 + 1536 + 1600 + 1680 + 1920 + 2560 + 3440 + 3840 + + + + False + False + 2 + + + + + True + False + False + Toggle on or off fullscreen + 5 + 5 + fullscreen-image + half + True + + + False + True + 3 + + + + + False + True + False + 5 + + + False + False + 4 + + + + + True + True + False + False + About Movie Monad + 5 + 5 + about-image + half + True + + + False + False + end + 5 + + + + False + False + 1 + False False - 1 - - - - - True - False - Set the max width. - 1 - False - 800 - - 320 - 800 - 1024 - 1152 - 1280 - 1360 - 1366 - 1440 - 1536 - 1600 - 1680 - 1920 - 2560 - 3440 - 3840 - - - - False - False - 2 - - - - - True - True - True - 5 - about-image - True - - - False - False end 3 - - - True - True - Toggle on or off fullscreen. - fullscreen-image - True - - - False - True - 4 - - - False - False - 1 + True + True + 0 @@ -236,7 +381,7 @@ False - Movie Monad + Movie Monad - About center dialog-information dialog @@ -244,8 +389,9 @@ window window Movie Monad - 0.0.1.0 - (C) 2017 David Lettier + 0.0.2.0 + (C) 2017 David Lettier +lettier.com https://github.com/lettier/movie-monad Update BSD 3-Clause License @@ -278,15 +424,15 @@ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. David Lettier - applications-multimedia + movie-monad-logo.svg custom - + False vertical 2 - + False end @@ -296,9 +442,6 @@ 0 - - - @@ -307,7 +450,7 @@ False - Movie Monad + Movie Monad - Error center True dialog-error @@ -319,15 +462,17 @@ error close There was an error. - Did you select a video file? -Did you install ExifTool? + If you feel like this is a bug, please visit <a href="https://github.com/lettier/movie-monad/issues">the issue page</a> to file a report. + +Thank you. + True - + False vertical 2 - + False True expand @@ -336,6 +481,73 @@ False False 0 + + + + + + + + + + False + Movie Monad - Open a Video File + dialog + window + + + False + vertical + 2 + top + + + False + bottom + end + + + + + + + + + False + False + 0 + + + + + True + True + Type in the path to a local file or URL + False + True + gtk-edit + gtk-clear + False + False + Clear the video location + Video Location + + + False + True + 0 + + + + + True + False + False + + + False + True + 1 diff --git a/src/data/movie-monad-icon.png b/src/data/movie-monad-icon.png new file mode 100644 Binary files /dev/null and b/src/data/movie-monad-icon.png differ diff --git a/src/data/movie-monad-logo.svg b/src/data/movie-monad-logo.svg new file mode 100644 --- /dev/null +++ b/src/data/movie-monad-logo.svg @@ -0,0 +1,768 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + image/svg+xml + + + + + + + + + + + + + + (C) DAVID LETTIER + +