diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,29 @@
+BSD 3-Clause License
+
+Copyright (c) 2017, David Lettier
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+ list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+
+* Neither the name of the copyright holder nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+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.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,40 @@
+
+
+# Movie Monad
+
+A desktop video player built with Haskell that uses GStreamer and GTK+.
+
+## Screenshots
+
+
+
+## Documentation
+
+[Let's make a GTK Video Player with Haskell](https://lettier.github.io/posts/2017-08-30-haskell-gtk-video-player.html)
+
+## Install
+
+### GitHub
+
+```bash
+# Install Git
+# Install Haskell
+# Install Haksell Stack
+# Install ExifTool
+git clone https://github.com/lettier/movie-monad.git
+cd movie-monad/
+stack setup
+stack install --dependencies-only
+haskell-gi -o lib/gi-gdkx11/GdkX11.overrides -O lib/gi-gdkx11 GdkX11-3.0
+haskell-gi -o lib/gi-xlib/xlib.overrides -O lib/gi-xlib xlib
+stack build
+stack install
+stack exec -- movie-monad
+```
+
+## License
+
+See [LICENSE](LICENSE).
+
+(C) 2017 David Lettier
+[lettier.com](http://www.lettier.com/)
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/movie-monad.cabal b/movie-monad.cabal
new file mode 100644
--- /dev/null
+++ b/movie-monad.cabal
@@ -0,0 +1,44 @@
+name: movie-monad
+version: 0.0.0.0
+synopsis: Plays videos using GStreamer and GTK+.
+description: Desktop video player that uses GStreamer and GTK+.
+homepage: https://github.com/lettier/movie-monad
+license: BSD3
+license-file: LICENSE
+author: Lettier
+maintainer: Lettier
+copyright: 2017 David Lettier
+category: Multimedia
+ , Multimedia Player
+ , Video
+build-type: Simple
+cabal-version: >=1.10
+extra-source-files: README.md
+ , LICENSE
+ , ./src/dev/Paths_movie_monad.hs
+ , ./src/data/gui.glade
+data-files: data/gui.glade
+data-dir: ./src/
+
+source-repository head
+ type: git
+ location: https://github.com/lettier/gifcurry.git
+
+executable movie-monad
+ main-is: Main.hs
+ default-language: Haskell2010
+ build-depends: base >= 4.7 && < 5
+ , text == 1.2.*
+ , process == 1.4.*
+ , MissingH == 1.4.*
+ , haskell-gi-base == 0.20.*
+ , gi-gobject == 2.0.*
+ , gi-gst == 1.0.*
+ , gi-gtk == 3.0.*
+ , gi-glib == 2.0.*
+ , gi-xlib == 0.1.6.*
+ , gi-gstvideo == 1.0.*
+ , gi-gdkx11 == 0.3.*
+ ghc-options: -threaded -with-rtsopts=-N -Wall
+ other-modules: Paths_movie_monad
+ hs-source-dirs: ./src/
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,232 @@
+{-
+ 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 Data.Maybe
+import Data.Int
+import Data.Text
+import Data.String.Utils
+import Data.GI.Base
+import Data.GI.Base.Properties
+import GI.GLib
+import GI.GObject
+import qualified GI.Gtk
+import GI.Gst
+import GI.GstVideo
+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"
+ 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")
+
+ _ <- GI.Gtk.onWidgetRealize drawingArea $ 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.onFileChooserButtonFileSet fileChooserButton $ do
+ _ <- GI.Gst.elementSetState playbin GI.Gst.StateNull
+
+ filename <- fromJust <$> GI.Gtk.fileChooserGetFilename fileChooserButton
+ 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)
+
+ desiredVideoWidth <- getDesiredVideoWidth desiredVideoWidthComboBox
+ (success, width, height) <- getWindowSize desiredVideoWidth filename
+
+ if success
+ then do
+ _ <- GI.Gst.elementSetState playbin GI.Gst.StatePlaying
+ GI.Gtk.switchSetActive onOffSwitch True
+ setWindowSize width height fileChooserButton drawingArea window
+ else do
+ _ <- GI.Gst.elementSetState playbin GI.Gst.StatePaused
+ GI.Gtk.switchSetActive onOffSwitch False
+ resetWindowSize desiredVideoWidth fileChooserButton drawingArea window
+ _ <- GI.Gtk.onDialogResponse errorMessageDialog (\ _ -> GI.Gtk.widgetHide errorMessageDialog)
+ void $ GI.Gtk.dialogRun errorMessageDialog
+
+ _ <- GI.Gtk.onSwitchStateSet onOffSwitch $ \ switchOn -> do
+ if switchOn
+ then void $ GI.Gst.elementSetState playbin GI.Gst.StatePlaying
+ else void $ GI.Gst.elementSetState playbin GI.Gst.StatePaused
+ return switchOn
+
+ _ <- GI.Gtk.onScaleButtonValueChanged volumeButton $
+ \ volume -> void $ Data.GI.Base.Properties.setObjectPropertyDouble playbin "volume" volume
+
+ seekScaleHandlerId <- GI.Gtk.onRangeValueChanged 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
+
+ _ <- GI.GLib.timeoutAddSeconds GI.GLib.PRIORITY_DEFAULT 1 $ 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
+
+ _ <- GI.Gtk.onComboBoxChanged desiredVideoWidthComboBox $ do
+ filename' <- GI.Gtk.fileChooserGetFilename fileChooserButton
+ let filename = fromMaybe "" filename'
+
+ desiredVideoWidth <- getDesiredVideoWidth desiredVideoWidthComboBox
+ (success, width, height) <- getWindowSize desiredVideoWidth filename
+
+ if success
+ then setWindowSize width height fileChooserButton drawingArea window
+ else resetWindowSize desiredVideoWidth fileChooserButton drawingArea window
+
+ _ <- GI.Gtk.onWidgetButtonReleaseEvent aboutButton $ \ _ -> do
+ _ <- GI.Gtk.onDialogResponse aboutDialog (\ _ -> GI.Gtk.widgetHide aboutDialog)
+ void $ GI.Gtk.dialogRun aboutDialog
+ return True
+
+ _ <- GI.Gtk.onWidgetDestroy window $ do
+ _ <- GI.Gst.elementSetState playbin GI.Gst.StateNull
+ _ <- GI.Gst.objectUnref playbin
+ GI.Gtk.mainQuit
+
+ 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
+
+getVideoInfo :: Prelude.String -> Prelude.String -> IO (Bool, Prelude.String)
+getVideoInfo flag filename = do
+ (code, out, _) <- catch (
+ readProcessWithExitCode
+ "exiftool"
+ [flag, "-s", "-S", filename]
+ ""
+ ) (\ (_ :: Control.Exception.IOException) -> return (ExitFailure 1, "", ""))
+ return (code == System.Exit.ExitSuccess, out)
+
+isVideo :: Prelude.String -> IO Bool
+isVideo filename = do
+ (success, out) <- getVideoInfo "-MIMEType" filename
+ return (success && isInfixOf "video" (pack out))
+
+getWindowSize :: Int -> Prelude.String -> IO (Bool, Int32, Int32)
+getWindowSize desiredVideoWidth filename = do
+ let defaultWidth = 800
+ let defaultHeight = 600
+
+ video <- isVideo filename
+
+ if video
+ then do
+ (success, out) <- getVideoInfo "-ImageSize" filename
+ if success && isInfixOf "x" (pack out)
+ then do
+ let (width''':height''':_) =
+ Data.String.Utils.split "x" $ Data.String.Utils.strip out
+
+ let width'' = read width''' :: Int
+ let height'' = read height''' :: Int
+
+ let ratio = fromIntegral height'' / fromIntegral width'' :: Double
+ let width' = fromIntegral desiredVideoWidth :: Double
+ let height' = width' * ratio
+ let width = fromIntegral (round width' :: Int) :: Int32
+ let height = fromIntegral (round height' :: Int) :: Int32
+
+ return (True, width, height)
+ else return (False, defaultHeight, defaultWidth)
+ else return (False, defaultHeight, defaultWidth)
+
+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
+ setWindowSize width 0 fileChooserButton drawingArea window
diff --git a/src/data/gui.glade b/src/data/gui.glade
new file mode 100644
--- /dev/null
+++ b/src/data/gui.glade
@@ -0,0 +1,313 @@
+
+
+
+
+
+
+
+
+
diff --git a/src/dev/Paths_movie_monad.hs b/src/dev/Paths_movie_monad.hs
new file mode 100644
--- /dev/null
+++ b/src/dev/Paths_movie_monad.hs
@@ -0,0 +1,17 @@
+{-
+ Movie Monad
+ (C) 2017 David lettier
+ lettier.com
+-}
+
+{-# 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)