Preview

Below you see the desktop video player we will build called, “Movie Monad.”

“Caminandes” and “Big Buck Bunny” from Blender Cloud.

Under the hood, the application uses the Electron framework which in turn uses Chromium and Node.js. Using only HTML, CSS, and JavaScript, you can use Electron to develop a desktop application. The nice part about Movie Monad, however, is that we will create the HTML, CSS, and JavaScript using Haskell.

Setup

In order to establish our build pipeline, we will need to setup our environment with a few tools, directories, and project files.

Stack

Stack will handle all of our Haskell environment needs from installing the compiler to managing our Haskell dependencies. The instructions contain all of the installation information you will need.

For a general Linux installation you could do:

cd Downloads
wget https://www.stackage.org/stack/linux-x86_64
tar xvzf stack-1.1.2-linux-x86_64.tar.gz
cd ~
echo 'export PATH="$HOME/Downloads/stack-1.1.2-linux-x86_64/:$PATH"' >> .bashrc
source .bashrc
# Or if you use ZSH.
echo 'export PATH="$HOME/Downloads/stack-1.1.2-linux-x86_64/:$PATH"' >> .zshrc
source .zshrc
stack

Project Directory

With Stack installed, we will need to create our project directory.

cd ~
mkdir -p movieMonad

We will also need to define some additional directories for our project.

cd ~/movieMonad
mkdir -p src/html src/css src/js src/electronBoot branding conf dist bin

With the directories in place, create the empty project files.

cd ~/movieMonad
touch src/html/Main.hs src/css/Main.hs src/js/Main.hs src/electronBoot/Main.hs conf/package.js branding/icon.png makefile

YAML

To use Stack, you will need to define a stack.yaml file in the root of the directory.

cd ~/movieMonad
touch stack.yaml

Go ahead and open this file with your favorite text editor and copy this information into the stack.yaml file.

resolver: lts-6.11
packages:
- '.'
extra-deps: []
flags: {}
extra-package-dbs: []

Cabal

We will also need an movieMonad.cabal file which Stack will use to build our project. Make sure this file is located in the root of the project.

cd ~/movieMonad
touch movieMonad.cabal

Go ahead and open this file with your favorite text editor and copy this information into the movieMonad.cabal file.

name:                movieMonad
version:             0.1.0.0
synopsis:            Desktop video player.
description:         Please see README.md
homepage:            https://github.com/lettier/moviemonad
license:             Apache
license-file:        LICENSE
author:              David Lettier
copyright:           2016 David Lettier
category:            Desktop
build-type:          Simple
cabal-version:       >=1.10

executable movieMonadCss
  hs-source-dirs:       src/css
  main-is:              Main.hs
  default-language:     Haskell2010
  build-depends:        base >= 4.7 && < 5
                      , clay

executable movieMonadHtml
  hs-source-dirs:       src/html
  main-is:              Main.hs
  default-language:     Haskell2010
  build-depends:        base >= 4.7 && < 5
                      , blaze-html

executable movieMonadJs
  hs-source-dirs:       src/js
  main-is:              Main.hs
  default-language:     Haskell2010
  build-depends:        base >= 4.7 && < 5
                      , cpphs
                      , fay
                      , fay-base
                      , fay-builder
                      , fay-dom
                      , fay-jquery
                      , fay-text
                      , fay-uri
                      , hlint

executable movieMonadElectronBoot
  hs-source-dirs:       src/electronBoot
  main-is:              Main.hs
  default-language:     Haskell2010
  build-depends:        base >= 4.7 && < 5
                      , cpphs
                      , fay
                      , fay-base
                      , fay-builder
                      , fay-dom
                      , fay-jquery
                      , fay-text
                      , fay-uri

NVM

To install Electron we will need Node.js which we will get via NVM.

cd ~/Downloads
wget -qO- https://raw.githubusercontent.com/creationix/nvm/v0.31.2/install.sh | bash
cd ~/movieMonad
echo 'v4.0.0' > .nvmrc
nvm use

Electron and Electron Packager

We will need Electron and Electron Packager to run and box up Movie Monad for distribution.

cd ~/movieMonad
nvm use
npm install -g electron electron-packager

Package.json

Electron needs a package.json file to run. Copy the following into ~/movieMonad/conf/package.json.

{
  "name"    : "movieMonad",
  "productName" : "movieMonad",
  "author": {
    "name": "David Lettier",
    "url": "http://www.lettier.com/"
  },
  "version" : "0.0.0.1",
  "main"    : "boot.js"
}

GNU Make

To automate our build process, we will use make. If you have ever used NPM scripts, you will be able to use make. Install make for your platform and then put the following in ~/movieMonad/makefile

# David Lettier (C) 2016
# http://www.lettier.com/

.RECIPEPREFIX != ps
PROJECT_NAME = movieMonad
HASKELL_PACKAGE_SANDBOX = ~/.stack/snapshots/x86_64-linux/lts-6.11/7.10.3/pkgdb/
FAY_PACKAGES = fay-jquery,fay-text
FAY_CC = HASKELL_PACKAGE_SANDBOX=$(HASKELL_PACKAGE_SANDBOX) fay --package $(FAY_PACKAGES) -p --Wall

all: build runElectron

build: clean gatherDependencies buildHaskell copyConf copyIcon buildElectronDists

clean: cleanDist cleanBin

cleanDist:
  mkdir -p dist && mkdir -p dist_old && rm -rf dist_old && mv -f dist dist_old && mkdir -p dist

cleanBin:
  mkdir -p bin && mkdir -p bin_old && rm -rf bin_old && mv -f bin bin_old && mkdir -p bin

gatherDependencies: installStackDependencies downloadJquery

installStackDependencies:
  stack install --dependencies-only

downloadJquery:
  wget http://ajax.googleapis.com/ajax/libs/jquery/1.10.2/jquery.min.js -O dist/jquery.js

buildHaskell: buildHtml buildCss buildJs

buildHtml:
  stack ghc -- src/html/Main.hs -o bin/$(PROJECT_NAME)Html && bin/$(PROJECT_NAME)Html > dist/index.html

buildCss:
  stack ghc -- src/css/Main.hs -o bin/$(PROJECT_NAME)Css && bin/$(PROJECT_NAME)Css > dist/all.css

buildJs:
  $(FAY_CC) -o dist/all.js src/js/Main.hs && \
  $(FAY_CC) -o dist/boot.js src/electronBoot/Main.hs

copyIcon:
  cp branding/icon.png dist/

copyConf:
  cp -R conf/. dist/

buildElectronDists:
  mkdir -p dist/electronDists/ && electron-packager dist/ --all --version 0.37.2 --out dist/electronDists

runElectron:
  electron dist/

Project Directory Structure

With our build environment setup, our project directory should look like the following.

~/movieMonad
  src/
    html/
      Main.hs
    css/
      Main.hs
    js/
      Main.hs
    electronBoot/
      Main.hs
  conf/
    package.json
  branding/
    icon.png
  bin/
  dist/
  stack.yaml
  movieMonad.cabal
  makefile

Code

The source code to Movie Monad consists of four major files.

HTML

Let us start with defining the HTML of Movie Monad. Since the application is fairly simple, we only need to define a little bit of structure.

{-# LANGUAGE OverloadedStrings #-}

This language extension allows us to take a string literal such as "Some text." and use it for arguments that require type ByteString, Text, or String/[Char] (a ['l','i','s','t'] or array of characters).

import Text.Blaze.Html.Renderer.Pretty
import Text.Blaze.Html5 as H hiding (main)
import Text.Blaze.Html5.Attributes as A

Here we import the needed Blaze modules. We will hide main as we will be defining it ourselves. When you see A–think Text.Blaze.Html5.Attributes.

main :: IO ()
main = putStrLn $ renderHtml $ docTypeHtml $ do

We start off with setting the document type, rendering the HTML to a string, and printing that string out.

  H.head $ do
    H.title    "Movie Monad - Lettier.com"
    styleSheet "https://fonts.googleapis.com/css?family=Oswald"
    styleSheet "https://cdnjs.cloudflare.com/ajax/libs/foundicons/3.0.0/foundation-icons.min.css"
    styleSheet "all.css"
    scriptSrc  "jquery.js"
    H.script $ toHtml' "if ('require' in window) { window.$ = window.jQuery = require('./jquery.js'); }"
    scriptSrc  "all.js"

This is where we describe the <head><!-...-></head> section of our HTML document. We will be using a custom font from Google and icons from Foundation. The all.css and all.js files are our own custom CSS and JavaScript which we will define later. The jquery.js is a local copy of the jQuery JavaScript library. The JavaScript string requires the jQuery library and sets the jQuery object as a property of the window. If we run Movie Monad with Electron and without this line, an exception will be raised that jQuery is undefined. This little bit of JavaScript will be ignored if Movie Monad is loaded inside the browser–as a normal web page–instead of running it with Electron.

  H.body $
    H.div ! A.id "pageContainer" $ do
      H.input ! A.id "fileInput" ! A.name "fileInput" ! A.type_ "file"
      H.label ! A.for "fileInput" $ H.i ! A.class_ "fi-upload" ! A.title "Upload a Video File" $ empty
      H.div   ! A.id "videoContainer" $ empty
      H.div   ! A.id "statusMessage" $ empty

The body of the document consists of a page container that holds a file input, label, video container, and a status message container which allows us to relay any feedback we have for the user.

This will translate into the following.

  <body>
    <div id="pageContainer">
      <input id="fileInput" name="fileInput" type="file" />
      <label for="fileInput">
        <i class="fi-upload"></i>
      </label>
      <div id="videoContainer"></div>
      <div id="statusMessage"></div>
    </div>
  </body>

Notice how $ empty defines the inner HTML as blank for any defined tag.

toHtml' :: String -> Html
toHtml' = toHtml

empty :: Html
empty = toHtml' ""

styleSheet :: AttributeValue -> Html
styleSheet s = H.link ! A.href s ! A.rel "stylesheet" ! A.type_ "text/css"

scriptSrc :: AttributeValue -> Html
scriptSrc s = H.script ! A.src s ! A.type_ "text/javascript" $ empty

These are helper functions to DRY up some of the code. Each one returns data with type Html. stylesheet "link" translates to <link href="link" rel="stylesheet" type="text/css" />.

Below is the entire ~/movieMonad/src/html/Main.hs file–be sure to copy it over.

{-
  David Lettier (C) 2016
  http://www.lettier.com/
-}

{-# LANGUAGE OverloadedStrings #-}

import Text.Blaze.Html.Renderer.Pretty
import Text.Blaze.Html5 as H hiding (main)
import Text.Blaze.Html5.Attributes as A

main :: IO ()
main = putStrLn $ renderHtml $ docTypeHtml $ do
  H.head $ do
    H.title    "Movie Monad - Lettier.com"
    styleSheet "https://fonts.googleapis.com/css?family=Oswald"
    styleSheet "https://cdnjs.cloudflare.com/ajax/libs/foundicons/3.0.0/foundation-icons.min.css"
    styleSheet "all.css"
    scriptSrc  "jquery.js"
    H.script $ toHtml' "if ('require' in window) { window.$ = window.jQuery = require('./jquery.js'); }"
    scriptSrc  "all.js"
  H.body $
    H.div ! A.id "pageContainer" $ do
      H.input ! A.id "fileInput" ! A.name "fileInput" ! A.type_ "file"
      H.label ! A.for "fileInput" $ H.i ! A.class_ "fi-upload" ! A.title "Upload a Video File" $ empty
      H.div   ! A.id "videoContainer" $ empty
      H.div   ! A.id "statusMessage" $ empty

toHtml' :: String -> Html
toHtml' = toHtml

empty :: Html
empty = toHtml' ""

styleSheet :: AttributeValue -> Html
styleSheet s = H.link ! A.href s ! A.rel "stylesheet" ! A.type_ "text/css"

scriptSrc :: AttributeValue -> Html
scriptSrc s = H.script ! A.src s ! A.type_ "text/javascript" $ empty

CSS

The CSS is fairly straightforward and nearly reads like a normal CSS file. Clay is a preprocessor like Sass or Less but you have the full expressiveness of Haskell at your disposal.

{-# LANGUAGE OverloadedStrings #-}

import Clay
import Clay.Box
import Clay.Transform

Like before, we list our language extensions and necessary module imports.

main :: IO ()
main = putCss $ do
  body ? do
    backgroundColor "#323A45"
    color           "#eee"
    fontFamily      ["Oswald"] [sansSerif]
    overflow        hidden
    height          $ pct 100
    width           $ pct 100
    marginAll       $ px 0

putCss will print out the generated CSS to standard out. You can see how we are defining the style for the main body of the document. Oswald is the custom font provided by Google. pct translates to %.

This block will translate roughly to the following.

body {
  background-color: "#323A45";
  /* ... */
}

  label ? do
    borderBottomStyle   solid
    borderBottomColor   $ rgba' 26 105  94 0.7969
    backgroundColor     $ rgba' 31 187 166 0.8
    boxShadow           (px 0) (px 10) (px 5) (rgba' 27 39 35 0.39)
    fontSize            $ px 60
    paddingAll          $ px 20
    borderBottomWidth   $ px 10
    display             inlineBlock
    cursor              pointer

This is the label for the file input box. It is here that we make it more like a button.

  video ? do
    height $ pct 100
    width  $ pct 100

The video dimensions should always fill the window to make it responsive. The user can adjust the window size and the video will scale to match while at the same time keeping its aspect ratio.

  "#pageContainer" ?
    textAlign (alignSide sideLeft)
  "#fileInput" ? do
    width        $ px 0
    outlineWidth $ px 0
    display      none
  "#videoContainer" ? do
    position absolute
    zIndex   (-1)
    top      $ px 0
    left     $ px 0
    height   $ pct 100
    width    $ pct 100
  "#statusMessage" ? do
    position   absolute
    minHeight  $ pct 100
    minWidth   $ pct 100
    paddingTop $ pct 25
    zIndex     (-2)
    top        $ px 0
    left       $ px 0
    width      $ pct 100
    height     $ pct 100
    fontSize   $ px 60
    textAlign  $ alignSide sideCenter

Here we use ID selectors to style the various containers, the file input, and the status message. The status message will always stay under the video.

paddingAll :: Size z -> Css
paddingAll s = padding s s s s

marginAll :: Size z -> Css
marginAll s = margin s s s s

rgba' :: Integer -> Integer -> Integer -> Double -> Color
rgba' r g b a = rgba r g b $ floor $ a * 255

These functions provide more convenience over the functions provided by Clay. The padding and margin functions allow us to have uniform sizes without having to specify the same size for all four sides. Typically the alpha channel (in rgba) is expressed in decimal with a range of zero to one instead of an integer with a range of zero to 255.

Below is the entire ~/movieMonad/src/css/Main.hs file–be sure to copy it over.

{-
  David Lettier (C) 2016
  http://www.lettier.com/
-}

{-# LANGUAGE OverloadedStrings #-}

import Clay
import Clay.Box
import Clay.Transform

-- Color scheme: http://flatcolors.net/palette/757-carbon-flat-colorful

main :: IO ()
main = putCss $ do
  body ? do
    backgroundColor "#323A45"
    color           "#eee"
    fontFamily      ["Oswald"] [sansSerif]
    overflow        hidden
    height          $ pct 100
    width           $ pct 100
    marginAll       $ px 0
  label ? do
    borderBottomStyle   solid
    borderBottomColor   $ rgba' 26 105  94 0.7969
    backgroundColor     $ rgba' 31 187 166 0.8
    boxShadow           (px 0) (px 10) (px 5) (rgba' 27 39 35 0.39)
    fontSize            $ px 60
    paddingAll          $ px 20
    borderBottomWidth   $ px 10
    display             inlineBlock
    cursor              pointer
  video ? do
    height $ pct 100
    width  $ pct 100
  "#pageContainer" ?
    textAlign (alignSide sideLeft)
  "#fileInput" ? do
    width        $ px 0
    outlineWidth $ px 0
    display      none
  "#videoContainer" ? do
    position absolute
    zIndex   (-1)
    top      $ px 0
    left     $ px 0
    height   $ pct 100
    width    $ pct 100
  "#statusMessage" ? do
    position   absolute
    minHeight  $ pct 100
    minWidth   $ pct 100
    paddingTop $ pct 25
    zIndex     (-2)
    top        $ px 0
    left       $ px 0
    width      $ pct 100
    height     $ pct 100
    fontSize   $ px 60
    textAlign  $ alignSide sideCenter

paddingAll :: Size z -> Css
paddingAll s = padding s s s s

marginAll :: Size z -> Css
marginAll s = margin s s s s

rgba' :: Integer -> Integer -> Integer -> Double -> Color
rgba' r g b a = rgba r g b $ floor $ a * 255

JavaScript

Now we get to the more exciting part where we can produce JavaScript by writing Haskell. The library that provides this functionality is Fay.

Application Logic

The logic to Movie Monad is straightforward.

The application waits for the user to click the label
Once the user clicks the label, a file selection dialog opens up
The user selects a file or cancels
If the file is within the appropriate size range
- Read in the file data
- Take the file data and encode it into a data URL
- If the encoded data URL has the video MIME type
  - Create a video element
  - Set the source of the video element to the data URL
- Else
  - Tell the user that the file is not a video
Else
- Tell the user that the file is either too small or too large
- Clear out the video container

{-# LANGUAGE RebindableSyntax, OverloadedStrings, EmptyDataDecls #-}

import Prelude
import FFI
import JQuery
import Fay.Text

We’ve seen OverloadedStrings strings before but not RebindableSyntax nor EmptyDataDecls. RebindableSyntax allows us to redefine (rebind) operators defined in the Prelude. Note that Fay has its own Prelude. EmptyDataDecls allows us to declare data types without specifying what they are equivalent to (no constructors). We will use this to define some custom data types for objects returned from the JavaScript world.

data File
data FileReader

These are our empty data type declarations. Notice that they do not have have constructors. File is a file object in the files property of the file input object. FileReader is the object we use to read in the video file selected by the user.

main :: Fay ()
main = startApp

startApp :: Fay ()
startApp = ready $ do
  fileInput' <- fileInput
  void $ change (const $ onFileInputChange fileInput') fileInput'

Instead of the IO monad, we operate in the Fay monad returning the unit type. In other words, we perform some side effects and return nothing of interest (think void).

The start app function gets the file input object and setups a change event. When the file input changes, it will call the onFileInputChange callback.

The const function take two parameters but if you call it with only one, it returns a function that takes any parameter and returns the result of the first parameter you originally called const with. This is useful because change expects a function that takes an event and returns the unit type. However, onFileInputChange does not take an event. change will call what const returns (passing it an event), the event passed will be ignored, and onFileInputChange will be called.

Prelude> static = const 1
Prelude> :t static
static :: Num a => b -> a
Prelude> static "2"
1
Prelude> static 1255.5
1
Prelude> static []
1

fileInput :: Fay JQuery
fileInput = select "#fileInput"

Using Fay-jQuery, we select the element with the #fileInput ID.

newFileReader :: Fay FileReader
newFileReader = ffi "new FileReader()"

ffi is short for foreign function interface. ffi allows us to call JavaScript from within our Haskell code. Notice how we return the FileReader data type (wrapped) within the Fay monad.

fileInputFiles :: JQuery -> Fay (Nullable [File])
fileInputFiles = ffi "%1['prop']('files')"

The syntax here is a little cryptic but it translates to $('#fileInput').prop('files'); in JavaScript. The %1 syntax is the first argument JQuery in the type signature where JQuery is some object returned by the select function. Our return type is Nullable [File] which means that we may either get back Null or a list of files [File]. The Null type translates to null in JavaScript.

fileSize :: File -> Fay Int
fileSize = ffi "%1['size']"

This takes a file object and calls size on it which returns an integer.

nullableFileSize :: Nullable File -> Fay Int
nullableFileSize nullableFile = case nullableFile of
                                  Nullable file -> fileSize file
                                  Null -> return 0

This function helps with getting the size of a file that may actually be null. If the file is null, just return zero.

fileSizeLimit :: Int
fileSizeLimit = 51000000

Because Movie Monad has to load the entire video file into memory, we have to limit the file size. If we do not limit the file size, the application could crash or freeze up for large video files. Ideally we would like to stream the video (play buffered chunks) from disk but the file reader API doesn’t allow for this. The file size limit number is in number of bytes–so the limit is roughly 48 megabytes.

fileInputFile :: JQuery -> Int -> Fay (Nullable File)
fileInputFile fileInput index = do
  nullableFiles <- fileInputFiles fileInput
  let files = case nullableFiles of
                Nullable files -> files
                Null -> []
  if Prelude.null files || (Prelude.length files <= index)
    then return Null
    else return (Nullable $ files!!index)

Taking the file input object, we gather up all of its input files. If there are no files, return null, otherwise return the requested file at the requested index.

fileReaderResult :: FileReader -> Fay Text
fileReaderResult = ffi "%1['result']"

Once the file reader has brought the file into memory, we can access it via its result property.

addFileReaderEventListener :: FileReader -> Text -> (Event -> Fay ()) -> Fay ()
addFileReaderEventListener = ffi "%1['addEventListener'](%2, %3)"

Taking a file reader object, specify a callback function to be called once the specified event type occurs.

// For example:

fileReader.addEventListener('load', function(event) {});

setUpNewFileRead :: Nullable File -> Fay ()
setUpNewFileRead Null = return ()
setUpNewFileRead (Nullable file) = do
  fr <- newFileReader
  let onLoadCallback = const $ handleVideoFile fr
  addFileReaderEventListener fr "load" onLoadCallback
  readAsDataURL fr file

If given a null file, do nothing. However, if we are given an actual file object, setup the callback and begin reading the file as a data URL.

onFileInputChange :: JQuery -> Fay ()
onFileInputChange fileInput = do
  emptyVideoContainer
  nullableFile <- fileInputFile fileInput 0
  nfs <- nullableFileSize nullableFile
  if (&&) (nfs > 0) (nfs <= fileSizeLimit)
    then setUpNewFileRead nullableFile
    else void $ setStatusMessage "File too small or large."

This is the callback we used in startApp. The video container may contain a previously loaded video. We clear it out making way for the new video or a possible status message. If the file size is within the valid range, read the file, otherwise let the user know that the file size is not valid.

File is too small or large.

setStatusMessage :: Text -> Fay JQuery
setStatusMessage text = select "#statusMessage" >>= setHtml text

Select the status message element and set its inner HTML to the text passed.

videoContainer :: Fay JQuery
videoContainer = select "#videoContainer"

Return the video container element.

addVideoElement :: Fay JQuery
addVideoElement = select "<video id='video' src='' controls/>" >>= addToVideoContainer

Much like jQuery, we can create a new document element by selecting it. Once created, we add it as a child element to the video container.

addToVideoContainer :: JQuery -> Fay JQuery
addToVideoContainer el = videoContainer >>= flip appendTo el

Given an element (el), grab the video container and append the element to it. appendTo takes two parameters where the first one is the parent and the second one is the child. flip turns this around making a new function where the first parameter is the child and the second one is the parent.

Prelude> x a b = a - b
Prelude> y = flip x
Prelude> x 1 2
-1
Prelude> y 1 2
1

This allows us to keep the syntax clean using a one-liner. Implicitly, flip appendTo el is being passed the video container like this:

addToVideoContainer el = videoContainer >>= (\ videoContainer' -> flip appendTo el videoContainer')

-- (>>=) :: Fay JQueryA        -> (JQueryA        -> Fay JQueryB) -> Fay JQueryB
-- (>>=) :: Fay videoContainer -> (videoContainer -> Fay el     ) -> Fay el

We could have written this function like the following.

addToVideoContainer :: JQuery -> Fay JQuery
addToVideoContainer el = do
  videoContainer' <- videoContainer
  appendTo videoContainer' el

-- Or like this:

addToVideoContainer :: JQuery -> Fay JQuery
addToVideoContainer el = videoContainer >>= (\ videoContainer' -> appendTo videoContainer' el)

emptyVideoContainer :: Fay JQuery
emptyVideoContainer = videoContainer >>= JQuery.empty

This clears out the video container document element.

handleVideoFile :: FileReader -> Fay ()
handleVideoFile fr = do
  url <- fileReaderResult fr
  if "data:video" `isPrefixOf` url
    then void $ addVideoElement >>= setAttr "src" url >> setStatusMessage ""
    else void $ setStatusMessage "Not a video file."

Here is where we check that the data URL has the video type. If it does not, we tell the user that the file is not a video file. However, if we are dealing with a video file, set the video element src to the data URL.

Not a video file.

readAsDataURL :: FileReader -> File -> Fay ()
readAsDataURL = ffi "%1['readAsDataURL'](%2)"

At long last we reach the end of the application logic where we read the file in as a data URL such that we can set this URL as the video source.

Below is the entire ~/movieMonad/src/js/Main.hs file–be sure to copy it over.

{-
  David Lettier (C) 2016
  http://www.lettier.com/
-}

{-# LANGUAGE RebindableSyntax, OverloadedStrings, EmptyDataDecls #-}

import Prelude
import FFI
import JQuery
import Fay.Text

data File
data FileReader

main :: Fay ()
main = startApp

startApp :: Fay ()
startApp = ready $ do
  fileInput' <- fileInput
  void $ change (const $ onFileInputChange fileInput') fileInput'

fileInput :: Fay JQuery
fileInput = select "#fileInput"

newFileReader :: Fay FileReader
newFileReader = ffi "new FileReader()"

fileInputFiles :: JQuery -> Fay (Nullable [File])
fileInputFiles = ffi "%1['prop']('files')"

fileSize :: File -> Fay Int
fileSize = ffi "%1['size']"

nullableFileSize :: Nullable File -> Fay Int
nullableFileSize nullableFile = case nullableFile of
                                  Nullable file -> fileSize file
                                  Null -> return 0

fileSizeLimit :: Int
fileSizeLimit = 51000000

fileInputFile :: JQuery -> Int -> Fay (Nullable File)
fileInputFile fileInput index = do
  nullableFiles <- fileInputFiles fileInput
  let files = case nullableFiles of
                Nullable files -> files
                Null -> []
  if Prelude.null files || (Prelude.length files <= index)
    then return Null
    else return (Nullable $ files!!index)

fileReaderResult :: FileReader -> Fay Text
fileReaderResult = ffi "%1['result']"

addFileReaderEventListener :: FileReader -> Text -> (Event -> Fay ()) -> Fay ()
addFileReaderEventListener = ffi "%1['addEventListener'](%2, %3)"

setUpNewFileRead :: Nullable File -> Fay ()
setUpNewFileRead Null = return ()
setUpNewFileRead (Nullable file) = do
  fr <- newFileReader
  let onLoadCallback = const $ handleVideoFile fr
  addFileReaderEventListener fr "load" onLoadCallback
  readAsDataURL fr file

onFileInputChange :: JQuery -> Fay ()
onFileInputChange fileInput = do
  emptyVideoContainer
  nullableFile <- fileInputFile fileInput 0
  nfs <- nullableFileSize nullableFile
  if (&&) (nfs > 0) (nfs <= fileSizeLimit)
    then setUpNewFileRead nullableFile
    else void $ setStatusMessage "File too small or large."

setStatusMessage :: Text -> Fay JQuery
setStatusMessage text = select "#statusMessage" >>= setHtml text

videoContainer :: Fay JQuery
videoContainer = select "#videoContainer"

addVideoElement :: Fay JQuery
addVideoElement = select "<video id='video' src='' controls/>" >>= addToVideoContainer

addToVideoContainer :: JQuery -> Fay JQuery
addToVideoContainer el = videoContainer >>= flip appendTo el

emptyVideoContainer :: Fay JQuery
emptyVideoContainer = videoContainer >>= JQuery.empty

handleVideoFile :: FileReader -> Fay ()
handleVideoFile fr = do
  url <- fileReaderResult fr
  if "data:video" `isPrefixOf` url
    then void $ addVideoElement >>= setAttr "src" url >> setStatusMessage ""
    else void $ setStatusMessage "Not a video file."

readAsDataURL :: FileReader -> File -> Fay ()
readAsDataURL = ffi "%1['readAsDataURL'](%2)"

Electron Boilerplate

Electron needs/runs a JavaScript file that creates the application window (or windows), defines the window properties, and setups the application callbacks like ready or window-all-close.

{-# LANGUAGE RebindableSyntax, OverloadedStrings, EmptyDataDecls #-}

import Prelude
import FFI
import Fay.Text

The same language extensions and imports as before.

data Electron
data App
data BrowserWindow
data MainWindow

New data types representing the electron, app, browser window, and main window JavaScript objects.

class OnCaller a

instance OnCaller App
instance OnCaller MainWindow

Here we create a new type class and declare the data types App and MainWindow members of this type class. On caller means they can call on in the JavaScript world. Now we do not have to write an onEvent function just for App and another one just for MainWindow. The onEvent definition is listed below.

type DirName = Text

Here we create a type alias that says DirName is just an alias for the Fay Text type. This provides some clarity in a function type signature. Yes it expects the Text type, but more specifically, it is looking for the result returned by calling __dirname in JavaScript. The DirName is the directory path in which this (eventual) JavaScript file resides.

main :: Fay ()
main = bootApp

bootApp :: Fay ()
bootApp = do
  electron' <- electron
  app' <- app electron'
  onEvent app' "ready" setupMainWindow
  onEvent app' "window-all-closed" $ do
    processPlatform' <- processPlatform
    when (processPlatform' /= "darwin") $ callAppProp app' "quit"
  onEvent app' "activate" $ void $ do
    nullableMainWindow <- getMainWindow
    case nullableMainWindow of
      Nullable _ -> return ()
      Null -> setupMainWindow

Here we gather the electron object and then the app object using the electron object. Two app event listeners are setup where we listen for the window closing and the application activating. If the application window is closed, we call app.quit() in JavaScript. When the activate event fires, we setup the main window if it does not already exist.

electron :: Fay Electron
electron = ffi "require('electron')"

require loads the electron module and returns the module object.

processPlatform :: Fay Text
processPlatform = ffi "process.platform"

This gives us the platform that Movie Monad is being run on.

app :: Electron -> Fay App
app = ffi "%1['app']"

Get the app object from the electron object.

callAppProp :: App -> Text -> Fay ()
callAppProp = ffi "%1[%2]()"

This translates to app.someProp();.

browserWindow :: Electron -> Fay BrowserWindow
browserWindow = ffi "%1['BrowserWindow']"

Retrieve the BrowserWindow constructor.

dirName :: Fay DirName
dirName = ffi "(function () { return __dirname; })()"

Create an IIFE which returns the directory path where this JavaScript file resides. Notice that it returns the DirName type which is aliased to Text.

windowWidth :: Int
windowWidth = 800

windowHeight :: Int
windowHeight = 600

The initial window width and height.

windowIcon :: DirName -> Fay Text
windowIcon = ffi "(function (d) { return d + '/icon.png'; })(%1)"

This returns the location of the icon file which will eventually show up in the taskbar.

newMainWindow :: BrowserWindow -> Int -> Int -> Text -> Fay MainWindow
newMainWindow = ffi "(function (b) { return global['mainWindow'] = new b({ width: %2, height: %3, icon: %4 }); })(%1)"

This is the largest foreign function interface definition we create. As you can see, it creates a new BrowserWindow instance and saves that instance in the global object under the mainWindow property.

Keep a global reference of the window object, if you don’t, the window will be closed automatically when the JavaScript object is garbage collected.
Electron Quick Start

getMainWindow :: Fay (Nullable MainWindow)
getMainWindow = ffi "(function () { var m = global['mainWindow']; return m ? m : null; })()"

Look up the main window in the global object. If the object is available, return it, otherwise return null. Because it is possible to return null, we set the return type as Nullable MainWindow.

onEvent :: OnCaller a => a -> Text -> Fay () -> Fay ()
onEvent = ffi "%1['on'](%2, %3)"

This can be used with any member of the OnCaller type class. Roughly translated: obj.on('eventType', callbackFunction);.

loadUrl :: MainWindow -> DirName -> Fay ()
loadUrl = ffi "%1['loadURL']('file://' + %2 + '/index.html')"

The start of the Movie Monad application begins with the HTML file we created earlier. This will load the user interface into the main application window.

setMainWindowNull :: Fay ()
setMainWindowNull = ffi "(function () { global['mainWindow'] = null; })()"

Sets the main window global property to null.

hideMainWindowMenu :: MainWindow -> Fay ()
hideMainWindowMenu = ffi "%1['setMenu'](null)"

To simplify the interface, we hide the main menu bar. During development, it is best to leave this visible.

setupMainWindow :: Fay ()
setupMainWindow = do
  nullableMainWindow <- getMainWindow
  mainWindow <- case nullableMainWindow of
                  Nullable mainWindow -> return mainWindow
                  Null -> do
                    electron' <- electron
                    browserWindow' <- browserWindow electron'
                    iconFile <- dirName >>= windowIcon
                    newMainWindow browserWindow' windowWidth windowHeight iconFile
  dirName >>= loadUrl mainWindow
  hideMainWindowMenu mainWindow
  onEvent mainWindow "close" setMainWindowNull

Creates the main window if it does not already exist, hides the menu bar, and sets the main window to null when we receive a close event.

Below is the entire ~/movieMonad/src/ electronBoot/Main.hs file–be sure to copy it over.

{-
  David Lettier (C) 2016
  http://www.lettier.com/
-}

{-# LANGUAGE RebindableSyntax, OverloadedStrings, EmptyDataDecls #-}

import Prelude
import FFI
import Fay.Text

data Electron
data App
data BrowserWindow
data MainWindow

class OnCaller a

instance OnCaller App
instance OnCaller MainWindow

type DirName = Text

main :: Fay ()
main = bootApp

bootApp :: Fay ()
bootApp = do
  electron' <- electron
  app' <- app electron'
  onEvent app' "ready" setupMainWindow
  onEvent app' "window-all-closed" $ do
    processPlatform' <- processPlatform
    when (processPlatform' /= "darwin") $ callAppProp app' "quit"
  onEvent app' "activate" $ void $ do
    nullableMainWindow <- getMainWindow
    case nullableMainWindow of
      Nullable _ -> return ()
      Null -> setupMainWindow

electron :: Fay Electron
electron = ffi "require('electron')"

processPlatform :: Fay Text
processPlatform = ffi "process.platform"

app :: Electron -> Fay App
app = ffi "%1['app']"

callAppProp :: App -> Text -> Fay ()
callAppProp = ffi "%1[%2]()"

browserWindow :: Electron -> Fay BrowserWindow
browserWindow = ffi "%1['BrowserWindow']"

dirName :: Fay DirName
dirName = ffi "(function () { return __dirname; })()"

windowWidth :: Int
windowWidth = 800

windowHeight :: Int
windowHeight = 600

windowIcon :: DirName -> Fay Text
windowIcon = ffi "(function (d) { return d + '/icon.png'; })(%1)"

newMainWindow :: BrowserWindow -> Int -> Int -> Text -> Fay MainWindow
newMainWindow = ffi "(function (b) { return global['mainWindow'] = new b({ width: %2, height: %3, icon: %4 }); })(%1)"

getMainWindow :: Fay (Nullable MainWindow)
getMainWindow = ffi "(function () { var m = global['mainWindow']; return m ? m : null; })()"

onEvent :: OnCaller a => a -> Text -> Fay () -> Fay ()
onEvent = ffi "%1['on'](%2, %3)"

loadUrl :: MainWindow -> DirName -> Fay ()
loadUrl = ffi "%1['loadURL']('file://' + %2 + '/index.html')"

setMainWindowNull :: Fay ()
setMainWindowNull = ffi "(function () { global['mainWindow'] = null; })()"

hideMainWindowMenu :: MainWindow -> Fay ()
hideMainWindowMenu = ffi "%1['setMenu'](null)"

setupMainWindow :: Fay ()
setupMainWindow = do
  nullableMainWindow <- getMainWindow
  mainWindow <- case nullableMainWindow of
                  Nullable mainWindow -> return mainWindow
                  Null -> do
                    electron' <- electron
                    browserWindow' <- browserWindow electron'
                    iconFile <- dirName >>= windowIcon
                    newMainWindow browserWindow' windowWidth windowHeight iconFile
  dirName >>= loadUrl mainWindow
  hideMainWindowMenu mainWindow
  onEvent mainWindow "close" setMainWindowNull

Build

So far we setup our build environment and we wrote out the source code. We are now ready to build the entire project.

cd ~/movieMonad
nvm use
make

If all went well, you should see the Movie Monad window open and ready to play videos. Located in ~/movieMonad/dist/electronDists are the packaged Linux, Windows, and Mac versions.

~/movieMonad
  dist/
    electronDists/
      movieMonad-darwin-x64/
      movieMonad-linux-ia32/
      movieMonad-linux-x64/
      movieMonad-mas-x64/
      movieMonad-win32-ia32/
      movieMonad-win32-x64/

If later on you only want to do some portion of the build process, you can pass make the target name.

cd ~/movieMonad
nvm use
make buildHaskell

Each target or build step is listed in the makefile you created earlier.

Recap

Using the Haskell libraries Blaze, Fay, and Clay, we generated the HTML, CSS, and JavaScript files necessary to build Movie Monad. These files, along with Electron and Electron Packager, allowed us to make a video playing desktop application and package it up for distribution to all major platforms. In Let’s make a GTK Video Player with Haskell, we take a different approach and build Movie Monad using GTK+ and GStreamer.

If you enjoy web programming in Haskell, be sure to read Building a Haskell Web API and Haskell to JavaScript.

Making Movie Monad |