webkit-0.14.2.1: demo/Webkit.hs

-- | WebKit browser demo.
--  Author      :  Andy Stewart
--  Copyright   :  (c) 2010 Andy Stewart <lazycat.manatee@gmail.com>

-- | This simple browser base on WebKit API.
-- For simple, i just make all link open in current window.
-- Of course, you can integrate signal `createWebView` with `notebook`
-- to build multi-tab browser.
--
-- You can click right-button for forward or backward page.
--
-- Usage:
--      webkit [uri]
--
module Main where

import           Control.Monad.Trans

import           Data.Text

import           Graphics.UI.Gtk
import           Graphics.UI.Gtk.WebKit.WebFrame
import           Graphics.UI.Gtk.WebKit.WebView

import           System.Environment
import           System.Process

-- | Main entry.
main :: IO ()
main = do
  -- Get program arguments.
  args <- getArgs
  case args of
    -- Display help
    ["--help"] ->
       putStrLn $ "Welcome to Gtk2hs WebKit demo. :)\n\n" ++
                  "Usage: webkit [uri]\n\n" ++
                  "  -- Gtk2hs Team"
    -- Start program.
    [arg]    -> browser arg                     -- entry user input url
    _        -> browser "http://www.google.com" -- entry default url

-- | Internal browser fucntion.
browser :: String -> IO ()
browser url = do
  -- Init.
  initGUI

  -- Create window.
  window <- windowNew
  windowSetDefaultSize window 900 600
  windowSetPosition window WinPosCenter
  set window [windowOpacity := 0.8]   -- this function need window-manager support Alpha channel in X11

  -- Create WebKit view.
  webView <- webViewNew

  -- Create window box.
  winBox <- vBoxNew False 0

  -- Create address bar.
  addressBar <- entryNew

  -- Create scroll window.
  scrollWin <- scrolledWindowNew Nothing Nothing

  -- Load uri.
  webViewLoadUri webView url
  entrySetText addressBar url

  -- Open uri when user press `return` at address bar.
  addressBar `on` entryActivated $ do
    uri <- entryGetText addressBar        -- get uri from address bar
    webViewLoadUri webView (uri :: Text)  -- load new uri

  -- Add current uri to address bar when load is committed.
  webView `on` loadCommitted $ \frame -> do
    currentUri <- webFrameGetUri frame
    case currentUri of
      Just uri -> entrySetText addressBar (uri :: Text)
      _ -> return ()

  -- Open all link in current window.
  webView `on` createWebView $ \frame -> do
    newUri <- webFrameGetUri frame
    case newUri of
      Just uri -> webViewLoadUri webView (uri :: Text)
      _ -> return ()
    return webView

  -- Connect and show.
  boxPackStart winBox addressBar PackNatural 0
  boxPackStart winBox scrollWin PackGrow 0
  window `containerAdd` winBox
  scrollWin `containerAdd` webView
  window `on` deleteEvent $ lift mainQuit >> return True
  widgetShowAll window

  mainGUI