hbro-0.4.6: examples/Main.hs
module Main where
-- {{{ Imports
import Hbro.Core
import Hbro.Gui
import Hbro.Util
import Graphics.Rendering.Pango.Layout
import Graphics.UI.Gtk.Abstract.Widget
import Graphics.UI.Gtk.Display.Label
import Graphics.UI.Gtk.Entry.Entry
import Graphics.UI.Gtk.Gdk.EventM
import Graphics.UI.Gtk.Gdk.GC
import Graphics.UI.Gtk.Misc.Adjustment
import Graphics.UI.Gtk.Scrolling.ScrolledWindow
import Graphics.UI.Gtk.WebKit.Download
import Graphics.UI.Gtk.WebKit.NetworkRequest
import Graphics.UI.Gtk.WebKit.WebFrame
import Graphics.UI.Gtk.WebKit.WebNavigationAction
import Graphics.UI.Gtk.WebKit.WebView
import Graphics.UI.Gtk.WebKit.WebSettings
import Graphics.UI.Gtk.Windows.Window
import System.Glib.Attributes
import System.Glib.Signals
import System.Process
import System.Posix.Process
-- }}}
main :: IO ()
main = browser Configuration {
-- Do not change this
mError = Nothing,
-- Directory where 0MQ sockets will be created
mSocketDir = socketDir,
-- URI loaded at startup
mHomePage = "https://www.google.com",
-- Custom keys
-- Note 1 : for modifiers, lists are used for convenience purposes,
-- but are transformed into sets in hbro's internal machinery,
-- so that order and repetition don't matter
-- Note 2 : for printable characters accessed via the shift modifier,
-- you do have to include Shift in modifiers list
mKeyBindings = [
-- ((Modifiers, Key), Callback)
-- Browse
(([], "<"), goBack),
(([Shift], ">"), goForward),
(([], "s"), stop),
(([], "<F5>"), reload True),
(([Shift], "<F5>"), reload False),
(([], "^"), horizontalHome),
(([], "$"), horizontalEnd),
(([], "<Home>"), verticalHome),
(([], "<End>"), verticalEnd),
-- Zoom
(([Shift], "+"), zoomIn),
(([], "-"), zoomOut),
-- Prompt
(([], "o"), promptURL False),
(([Shift], "O"), promptURL True),
-- Search
(([Shift], "/"), promptFind False True True),
(([Shift], "?"), promptFind False False True),
(([], "n"), findNext False True True),
(([Shift], "N"), findNext False False True),
-- Copy/paste
(([], "y"), copyUri),
(([Control], "y"), copyTitle),
--(([], "p"), pasteUri), -- /!\ UNSTABLE, can't see why...
-- Bookmarks
(([Control], "d"), addToBookmarks),
(([Control], "l"), loadFromBookmarks),
-- Others
(([Control], "i"), showWebInspector),
(([Control], "u"), toggleSourceMode),
(([], "t"), toggleStatusBar),
(([Control], "p"), printPage),
(([], "<F11>"), fullscreen),
(([], "<Escape>"), unfullscreen)
],
-- Various web settings
-- Commented lines correspond to default values
-- For more details, please refer to WebSettings documentation
mWebSettings = do
settings <- webSettingsNew
set settings [
--SETTING DEFAULT VALUE
--webSettingsCursiveFontFamily := "serif",
--webSettingsDefaultFontFamily := "sans-serif",
--webSettingsFantasyFontFamily := ,
--webSettingsMonospaceFontFamily := "monospace",
--webSettingsSansFontFamily := "sans-serif",
--webSettingsSerifFontFamily := "serif",
--webSettingsDefaultFontSize := ,
--webSettingsDefaultMonospaceFontSize := 10,
--webSettingsMinimumFontSize := 5,
--webSettingsMinimumLogicalFontSize := 5,
--webSettingsAutoLoadImages := True,
--webSettingsAutoShrinkImages := True,
--webSettingsDefaultEncoding := "iso-8859-1",
--webSettingsEditingBehavior := EditingBehaviorWindows,
--webSettingsEnableCaretBrowsing := ,
webSettingsEnableDeveloperExtras := True,
webSettingsEnableHtml5Database := False,
webSettingsEnableHtml5LocalStorage := False,
webSettingsEnableOfflineWebApplicationCache := True,
webSettingsEnablePlugins := True,
webSettingsEnablePrivateBrowsing := False,
webSettingsEnableScripts := True,
webSettingsEnableSpellChecking := True,
webSettingsEnableUniversalAccessFromFileUris := True,
webSettingsEnableXssAuditor := True,
--webSettingsEnableSiteSpecificQuirks := False,
--webSettingsEnableDomPaste := False,
--webSettingsEnableDefaultContextMenu := True,
webSettingsEnablePageCache := True,
--webSettingsEnableSpatialNavigation := False,
--webSettingsEnforce96Dpi := ,
webSettingsJSCanOpenWindowAuto := True,
--webSettingsPrintBackgrounds := True,
--webSettingsResizableTextAreas := True,
webSettingsSpellCheckingLang := Just "en_US",
--webSettingsTabKeyCyclesThroughElements := True,
webSettingsUserAgent := "Mozilla/5.0 (Windows; U; Windows NT 6.1; ru; rv:1.9.2.3) Gecko/20100401 Firefox/4.0 (.NET CLR 3.5.30729)"
--webSettingsUserStylesheetUri := Nothing,
--webSettingsZoomStep := 0.1
]
return settings,
-- Custom callbacks
mAtStartUp = \gui -> (let
webView = mWebView gui
scrollWindow = mScrollWindow gui
progressLabel = mProgressLabel gui
urlLabel = mUrlLabel gui
scrollLabel = mScrollLabel gui
window = mWindow gui
in do
-- Default background (for status bar)
widgetModifyBg window StateNormal (Color 0 0 10000)
-- Scroll position in status bar
adjustment <- scrolledWindowGetVAdjustment scrollWindow
_ <- onValueChanged adjustment $ do
current <- adjustmentGetValue adjustment
lower <- adjustmentGetLower adjustment
upper <- adjustmentGetUpper adjustment
page <- adjustmentGetPageSize adjustment
case upper-lower-page of
0 -> labelSetMarkup scrollLabel "ALL"
x -> labelSetMarkup scrollLabel $ show (round $ current/x*100) ++ "%"
-- Page load
_ <- on webView loadStarted $ \_ -> do
labelSetMarkup progressLabel "<span foreground=\"red\">0%</span>"
_ <- on webView loadCommitted $ \_ -> do
getUri <- (webViewGetUri webView)
case getUri of
Just uri -> labelSetMarkup urlLabel $ "<span weight=\"bold\" foreground=\"white\">" ++ escapeMarkup uri ++ "</span>"
_ -> labelSetMarkup urlLabel "<span weight=\"bold\" foreground=\"red\">ERROR</span>"
_ <- on webView progressChanged $ \progress' ->
labelSetMarkup progressLabel $ "<span foreground=\"yellow\">" ++ show progress' ++ "%</span>"
_ <- on webView loadFinished $ \_ -> do
labelSetMarkup progressLabel "<span foreground=\"green\">100%</span>"
getUri <- webViewGetUri webView
getTitle <- webViewGetTitle webView
case (getUri, getTitle) of
(Just uri, Just title) -> historyHandler uri title
_ -> return ()
_ <- on webView loadError $ \_ _ _ -> do
labelSetMarkup progressLabel "<span foreground=\"red\">ERROR</span>"
return False
_ <- on webView titleChanged $ \_ title ->
set window [ windowTitle := ("hbro | " ++ title)]
-- Special requests
_ <- on webView downloadRequested $ \download -> do
getUri <- downloadGetUri download
_ <- case getUri of
Just uri -> downloadHandler uri
_ -> return ()
return True
_ <- on webView mimeTypePolicyDecisionRequested $ \_ request mimetype policyDecision -> do
getUri <- networkRequestGetUri request
case (getUri, mimetype) of
--(Just uri, 'a':'p':'p':'l':'i':'c':'a':'t':'i':'o':'n':'/':_) -> downloadHandler uri
(Just uri, _) -> putStrLn $ mimetype ++ ": " ++ uri
_ -> putStrLn "FIXME"
return False
-- On navigating to a new URI
-- Return True to forbid navigation, False to allow
_ <- on webView navigationPolicyDecisionRequested $ \_ request action policyDecision -> do
getUri <- networkRequestGetUri request
reason <- webNavigationActionGetReason action
mouseButton <- webNavigationActionGetButton action
case getUri of
Just ('m':'a':'i':'l':'t':'o':':':address) -> do
putStrLn $ "Mailing to: " ++ address
return True
Just uri ->
case mouseButton of
1 -> return False -- Left button
2 -> runExternalCommand ("hbro \"" ++ uri ++ "\"") >> return True -- Middle button
3 -> return False -- Right button
_ -> return False -- No mouse button pressed
_ -> return False
-- On requesting new window
_ <- on webView newWindowPolicyDecisionRequested $ \_ request action policyDecision -> do
getUri <- networkRequestGetUri request
case getUri of
Just uri -> runExternalCommand $ "hbro " ++ uri
_ -> putStrLn "ERROR: wrong URI given, unable to open window."
return True
_ <- on webView hoveringOverLink $ \title hoveredUri -> do
getUri <- (webViewGetUri webView)
case (hoveredUri, getUri) of
(Just u, _) -> labelSetMarkup urlLabel $ "<span foreground=\"#5555ff\">" ++ escapeMarkup u ++ "</span>"
(_, Just u) -> labelSetMarkup urlLabel $ "<span foreground=\"white\" weight=\"bold\">" ++ escapeMarkup u ++ "</span>"
_ -> putStrLn "FIXME"
-- Favicon
--_ <- on webView iconLoaded $ \uri -> do something
return ()
)}
-- Definitions
where
-- Constants
scriptsDir :: String
scriptsDir = "~/.config/hbro/scripts/"
socketDir :: String
socketDir = "/tmp"
-- Browse
goBack :: GUI -> IO ()
goBack gui = webViewGoBack (mWebView gui)
goForward :: GUI -> IO ()
goForward gui = webViewGoForward (mWebView gui)
stop :: GUI -> IO ()
stop gui = webViewStopLoading (mWebView gui)
reload :: Bool -> GUI -> IO ()
reload True gui = webViewReload (mWebView gui)
reload _ gui = webViewReloadBypassCache (mWebView gui)
-- Zoom
zoomIn :: GUI -> IO ()
zoomIn gui = webViewZoomIn (mWebView gui)
zoomOut :: GUI -> IO ()
zoomOut gui = webViewZoomOut (mWebView gui)
toggleSourceMode :: GUI -> IO ()
toggleSourceMode gui = do
currentMode <- webViewGetViewSourceMode (mWebView gui)
webViewSetViewSourceMode (mWebView gui) (not currentMode)
-- TODO
toggleStatusBar :: GUI -> IO ()
toggleStatusBar gui = return()
promptURL :: Bool -> GUI -> IO ()
promptURL False gui =
prompt "Open URL" "" False gui (\g -> do
uri <- entryGetText (mPrompt g)
loadURL uri g)
promptURL _ gui = do
uri <- webViewGetUri (mWebView gui)
case uri of
Just url -> prompt "Open URL" url False gui (\g -> do
u <- entryGetText (mPrompt g)
loadURL u g)
_ -> return ()
promptFind :: Bool -> Bool -> Bool -> GUI -> IO ()
promptFind caseSensitive forward wrap gui =
prompt "Search" "" True gui (\gui' -> do
keyWord <- entryGetText (mPrompt gui')
found <- webViewSearchText (mWebView gui) keyWord caseSensitive forward wrap
return ())
findNext :: Bool -> Bool -> Bool -> GUI -> IO()
findNext caseSensitive forward wrap gui = do
keyWord <- entryGetText (mPrompt gui)
found <- webViewSearchText (mWebView gui) keyWord caseSensitive forward wrap
return ()
printPage :: GUI -> IO ()
printPage gui = do
frame <- webViewGetMainFrame (mWebView gui)
webFramePrint frame
fullscreen :: GUI -> IO ()
fullscreen gui = windowFullscreen (mWindow gui)
unfullscreen :: GUI -> IO ()
unfullscreen gui = windowUnfullscreen (mWindow gui)
-- Copy/paste
copyUri :: GUI -> IO ()
copyUri gui = do
getUri <- webViewGetUri (mWebView gui)
case getUri of
Just u -> runCommand ("echo -n " ++ u ++ " | xclip") >> return ()
_ -> return ()
copyTitle :: GUI -> IO ()
copyTitle gui = do
getTitle <- webViewGetTitle (mWebView gui)
case getTitle of
Just t -> runCommand ("echo -n " ++ t ++ " | xclip") >> return ()
_ -> return ()
pasteUri :: GUI -> IO ()
pasteUri gui = do
uri <- readProcess "xclip" ["-o"] []
loadURL uri gui
-- Scrolling
verticalHome :: GUI -> IO ()
verticalHome gui = do
adjustment <- scrolledWindowGetVAdjustment (mScrollWindow gui)
min <- adjustmentGetLower adjustment
adjustmentSetValue adjustment min
verticalEnd :: GUI -> IO ()
verticalEnd gui = do
adjustment <- scrolledWindowGetVAdjustment (mScrollWindow gui)
upper <- adjustmentGetUpper adjustment
adjustmentSetValue adjustment upper
horizontalHome :: GUI -> IO ()
horizontalHome gui = do
adjustment <- scrolledWindowGetHAdjustment (mScrollWindow gui)
lower <- adjustmentGetLower adjustment
adjustmentSetValue adjustment lower
horizontalEnd :: GUI -> IO ()
horizontalEnd gui = do
adjustment <- scrolledWindowGetHAdjustment (mScrollWindow gui)
upper <- adjustmentGetUpper adjustment
adjustmentSetValue adjustment upper
-- Handlers
downloadHandler :: String -> IO ()
downloadHandler uri = runExternalCommand $ "wget \"" ++ uri ++ "\""
historyHandler :: String -> String -> IO ()
historyHandler uri title = runCommand (scriptsDir ++ "/historyHandler.sh \"" ++ uri ++ "\" \"" ++ title ++ "\"") >> return ()
-- Bookmarks
addToBookmarks :: GUI -> IO ()
addToBookmarks gui = do
getUri <- webViewGetUri (mWebView gui)
case getUri of
Just uri -> prompt "Bookmark with tag:" "" False gui (\g -> do
tags <- entryGetText (mPrompt g)
runExternalCommand $ scriptsDir ++ "bookmarks.sh add " ++ uri ++ " " ++ tags)
_ -> return ()
loadFromBookmarks :: GUI -> IO ()
loadFromBookmarks gui = do
pid <- getProcessID
runExternalCommand $ scriptsDir ++ "bookmarks.sh load \"" ++ socketDir ++ "/hbro." ++ show pid ++ "\""