hbro 0.5.3 → 0.6.0
raw patch · 11 files changed
+618/−487 lines, 11 files
Files
- Hbro/Config.hs +36/−0
- Hbro/Core.hs +34/−28
- Hbro/Extra.hs +184/−0
- Hbro/Gui.hs +16/−4
- Hbro/Main.hs +22/−0
- Hbro/Socket.hs +15/−2
- Hbro/Types.hs +12/−5
- Hbro/Util.hs +5/−4
- examples/Main.hs +0/−441
- examples/hbro.hs +287/−0
- hbro.cabal +7/−3
+ Hbro/Config.hs view
@@ -0,0 +1,36 @@+module Hbro.Config where++-- {{{ Imports+import Hbro.Core+import Hbro.Types++import qualified Config.Dyre as Dyre++import Graphics.UI.Gtk.WebKit.WebSettings+-- }}}++-- {{{ Dyre+showError :: Configuration -> String -> Configuration+showError configuration message = configuration { mError = Just message }++hbro :: Configuration -> IO ()+hbro = Dyre.wrapMain Dyre.defaultParams {+ Dyre.projectName = "hbro",+ Dyre.showError = showError,+ Dyre.realMain = realMain,+ Dyre.ghcOpts = ["-threaded"]+}+-- }}}++-- | Default configuration.+-- Does quite nothing.+defaultConfiguration :: Configuration+defaultConfiguration = Configuration {+ mHomePage = "https://www.google.com",+ mSocketDir = "/tmp/",+ mUIFile = "~/.config/hbro/ui.xml",+ mKeys = [],+ mWebSettings = webSettingsNew,+ mSetup = \_ -> return () :: IO (),+ mError = Nothing+}
Hbro/Core.hs view
@@ -7,7 +7,6 @@ import Hbro.Types import Hbro.Util -import qualified Config.Dyre as Dyre import Control.Concurrent import Control.Monad.Trans(liftIO) @@ -18,9 +17,10 @@ import Graphics.UI.Gtk.Abstract.Widget import Graphics.UI.Gtk.General.General import Graphics.UI.Gtk.Gdk.EventM+import Graphics.UI.Gtk.Misc.Adjustment+import Graphics.UI.Gtk.Scrolling.ScrolledWindow import Graphics.UI.Gtk.WebKit.WebView import Graphics.UI.Gtk.WebKit.WebFrame---import Graphics.UI.Gtk.Windows.Window import Network.URL import Prelude@@ -28,7 +28,6 @@ import System.Console.CmdArgs import System.Glib.Signals import System.Posix.Process-import qualified System.ZMQ as ZMQ -- }}} -- {{{ Commandline options@@ -73,31 +72,21 @@ let webView = mWebView gui -- Initialize IPC socket- pid <- getProcessID- context <- ZMQ.init 1- repSocket <- ZMQ.socket context ZMQ.Rep + pid <- getProcessID let socketURI = "ipc://" ++ (mSocketDir configuration) ++ "/hbro." ++ show pid - ZMQ.bind repSocket socketURI- - _ <- quitAdd 0 $ do- ZMQ.setOption repSocket (ZMQ.Linger 0)- ZMQ.close repSocket- ZMQ.term context- return False-- _ <- forkIO $ listenToSocket repSocket browser+ _ <- forkIO $ createRepSocket socketURI browser -- Load configuration settings <- mWebSettings configuration webViewSetWebSettings webView settings- (mAtStartUp configuration) browser+ (mSetup configuration) browser -- Load homepage goHome browser -- Load key bindings- let keyBindings = importKeyBindings (mKeyBindings configuration)+ let keyBindings = importKeyBindings (mKeys configuration) -- On new window request --newWindowWebView <- webViewNew@@ -218,17 +207,34 @@ webViewLoadUri (mWebView $ mGUI browser) ("file://" ++ exportURL url) >> putStrLn (show url) loadURL' url@URL {url_type = _} browser = webViewLoadUri (mWebView $ mGUI browser) ("http://" ++ exportURL url) >> print url--- }}} --- {{{ Dyre-showError :: Configuration -> String -> Configuration-showError configuration message = configuration { mError = Just message }+-- Scrolling functions+verticalHome, verticalEnd, horizontalHome, horizontalEnd :: Browser -> IO ()+verticalHome browser = do+ adjustment <- scrolledWindowGetVAdjustment (mScrollWindow $ mGUI browser)+ lower <- adjustmentGetLower adjustment -hbro :: Configuration -> IO ()-hbro = Dyre.wrapMain Dyre.defaultParams {- Dyre.projectName = "hbro",- Dyre.showError = showError,- Dyre.realMain = realMain,- Dyre.ghcOpts = ["-threaded"]-}+ adjustmentSetValue adjustment lower++verticalEnd browser = do+ adjustment <- scrolledWindowGetVAdjustment (mScrollWindow $ mGUI browser)+ upper <- adjustmentGetUpper adjustment++ adjustmentSetValue adjustment upper++horizontalHome browser = do+ adjustment <- scrolledWindowGetHAdjustment (mScrollWindow $ mGUI browser)+ lower <- adjustmentGetLower adjustment++ adjustmentSetValue adjustment lower++horizontalEnd browser = do+ adjustment <- scrolledWindowGetHAdjustment (mScrollWindow $ mGUI browser)+ upper <- adjustmentGetUpper adjustment++ adjustmentSetValue adjustment upper ++-- | Spawn a new instance of the browser+newWindow :: Browser -> IO ()+newWindow browser = runExternalCommand ("hbro") -- }}}
+ Hbro/Extra.hs view
@@ -0,0 +1,184 @@+module Hbro.Extra where++-- {{{ Imports+import Hbro.Core+import Hbro.Gui+import Hbro.Types+import Hbro.Util ++import Control.Monad.Trans(liftIO)++import Graphics.Rendering.Pango.Layout++import Graphics.UI.Gtk.Abstract.Widget+import Graphics.UI.Gtk.Builder+import Graphics.UI.Gtk.Display.Label+import Graphics.UI.Gtk.Entry.Entry+import Graphics.UI.Gtk.Gdk.EventM+import Graphics.UI.Gtk.Misc.Adjustment+import Graphics.UI.Gtk.Scrolling.ScrolledWindow+import Graphics.UI.Gtk.WebKit.WebView++import System.Glib.Signals++import System.Process+-- }}}++-- {{{ Statusbar elements+-- | Display scroll position in status bar.+-- Needs a Label intitled "scroll" from the builder.+statusBarScrollPosition :: Browser -> IO ()+statusBarScrollPosition browser = + let+ builder = mBuilder (mGUI browser)+ scrollWindow = mScrollWindow (mGUI browser)+ in do+ scrollLabel <- builderGetObject builder castToLabel "scroll"++ 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) ++ "%"+ return ()+++-- | Display pressed keys in status bar.+-- Needs a Label intitled "keys" from the builder.+statusBarPressedKeys :: Browser -> IO ()+statusBarPressedKeys browser = + let+ builder = mBuilder (mGUI browser)+ webView = mWebView (mGUI browser)+ in do+ keysLabel <- builderGetObject builder castToLabel "keys"+ + _ <- after webView keyPressEvent $ do+ value <- eventKeyVal+ modifiers <- eventModifier++ let keyString = keyToString value+ case keyString of + Just string -> liftIO $ labelSetMarkup keysLabel $ "<span foreground=\"green\">" ++ show modifiers ++ escapeMarkup string ++ "</span>"+ _ -> return ()++ return False+ return ()+++-- | Display load progress in status bar.+-- Needs a Label intitled "progress" from the builder.+statusBarLoadProgress :: Browser -> IO ()+statusBarLoadProgress browser = + let+ builder = mBuilder (mGUI browser)+ webView = mWebView (mGUI browser)+ in do+ progressLabel <- builderGetObject builder castToLabel "progress"++ _ <- on webView loadStarted $ \_ -> do+ labelSetMarkup progressLabel "<span foreground=\"red\">0%</span>"+ + _ <- on webView progressChanged $ \progress' ->+ labelSetMarkup progressLabel $ "<span foreground=\"yellow\">" ++ show progress' ++ "%</span>"++ _ <- on webView loadFinished $ \_ -> do+ labelSetMarkup progressLabel "<span foreground=\"green\">100%</span>"++ _ <- on webView loadError $ \_ _ _ -> do+ labelSetMarkup progressLabel "<span foreground=\"red\">ERROR</span>"+ return False+ return ()+++-- | Display current URI, or the destination of a hovered link, in the status bar.+-- Needs a Label intitled "uri" from the builder.+statusBarURI :: Browser -> IO ()+statusBarURI browser = + let+ builder = mBuilder (mGUI browser)+ webView = mWebView (mGUI browser)+ in do+ uriLabel <- builderGetObject builder castToLabel "uri"+ + _ <- on webView loadCommitted $ \_ -> do+ getUri <- (webViewGetUri webView)+ case getUri of + Just uri -> labelSetMarkup uriLabel $ "<span weight=\"bold\" foreground=\"white\">" ++ escapeMarkup uri ++ "</span>"+ _ -> labelSetMarkup uriLabel "<span weight=\"bold\" foreground=\"red\">ERROR</span>"++ _ <- on webView hoveringOverLink $ \title hoveredUri -> do+ getUri <- (webViewGetUri webView)+ case (hoveredUri, getUri) of+ (Just u, _) -> labelSetMarkup uriLabel $ "<span foreground=\"#5555ff\">" ++ escapeMarkup u ++ "</span>"+ (_, Just u) -> labelSetMarkup uriLabel $ "<span foreground=\"white\" weight=\"bold\">" ++ escapeMarkup u ++ "</span>"+ _ -> putStrLn "FIXME"+ return ()+-- }}}++-- {{{ Features prompts+-- | Prompt for key words to search in current webpage.+promptFind :: Bool -> Bool -> Bool -> Browser -> IO ()+promptFind caseSensitive forward wrap browser =+ prompt "Search" "" True browser (\browser' -> do+ keyWord <- entryGetText (mPromptEntry $ mGUI browser')+ found <- webViewSearchText (mWebView $ mGUI browser) keyWord caseSensitive forward wrap+ return ())++-- | Switch to next found key word.+findNext :: Bool -> Bool -> Bool -> Browser -> IO ()+findNext caseSensitive forward wrap browser = do+ keyWord <- entryGetText (mPromptEntry $ mGUI browser)+ found <- webViewSearchText (mWebView $ mGUI browser) keyWord caseSensitive forward wrap + return ()++-- | Prompt for URI to open in current window.+promptURL :: Bool -> Browser -> IO() +promptURL False browser = + prompt "Open URL" "" False browser (\b -> do + uri <- entryGetText (mPromptEntry $ mGUI b)+ loadURL uri b)+promptURL _ browser = do+ uri <- webViewGetUri (mWebView $ mGUI browser)+ case uri of+ Just url -> prompt "Open URL" url False browser (\b -> do+ u <- entryGetText (mPromptEntry $ mGUI b)+ loadURL u b)+ _ -> return ()+-- }}}++-- {{{ Copy/paste+copyUri, copyTitle, loadURIFromClipBoard :: Browser -> IO()++-- | Copy current URI in clipboard.+copyUri browser = do+ getUri <- webViewGetUri (mWebView $ mGUI browser)+ case getUri of+ Just u -> runCommand ("echo -n " ++ u ++ " | xclip") >> return ()+ _ -> return ()++-- | Copy current page title in clipboard.+copyTitle browser = do+ getTitle <- webViewGetTitle (mWebView $ mGUI browser)+ case getTitle of+ Just t -> runCommand ("echo -n " ++ t ++ " | xclip") >> return ()+ _ -> return ()++-- | Load URI from clipboard. Does not work for now...+loadURIFromClipBoard browser = do+ uri <- readProcess "xclip" ["-o"] []+ loadURL uri browser+-- }}}++-- {{{ Others+toggleSourceMode :: Browser -> IO ()+toggleSourceMode browser = do+ currentMode <- webViewGetViewSourceMode (mWebView $ mGUI browser)+ webViewSetViewSourceMode (mWebView $ mGUI browser) (not currentMode)+ reload True browser+-- }}}
Hbro/Gui.hs view
@@ -41,9 +41,6 @@ -- Load main window window <- builderGetObject builder castToWindow "mainWindow" windowSetDefault window (Just webView)- --windowSetDefaultSize window 1024 768- --windowSetPosition window WinPosCenter- --windowSetIconFromFile window "/path/to/icon" set window [ windowTitle := "hbro" ] scrollWindow <- builderGetObject builder castToScrolledWindow "webViewParent"@@ -183,6 +180,21 @@ return () -- }}} -fullscreen, unfullscreen :: Browser -> IO()+-- {{{ Util+-- | Toggle statusbar's visibility+toggleStatusBar :: Browser -> IO ()+toggleStatusBar browser = do+ visibility <- get (mStatusBox $ mGUI browser) widgetVisible+ case visibility of+ False -> widgetShow (mStatusBox $ mGUI browser)+ _ -> widgetHide (mStatusBox $ mGUI browser)+++-- | Set the window fullscreen+fullscreen :: Browser -> IO () fullscreen browser = windowFullscreen (mWindow $ mGUI browser)++-- | Restore the window from fullscreen+unfullscreen :: Browser -> IO () unfullscreen browser = windowUnfullscreen (mWindow $ mGUI browser)+-- }}}
+ Hbro/Main.hs view
@@ -0,0 +1,22 @@+module Main where++-- {{{ Imports+import Hbro.Config+import Hbro.Types++import System.Environment++import Paths_hbro+-- }}}++main :: IO ()+main = do+ uiFile <- getDataFileName "examples/ui.xml"+ configHome <- getEnv "XDG_CONFIG_HOME"++ putStrLn "[WARNING] You are running the default configuration which provides hardly no feature."+ putStrLn $ "[WARNING] You should copy the example configuration files hbro.hs and ui.xml in " ++ configHome ++ "/hbro and start hacking them."++ hbro defaultConfiguration {+ mUIFile = uiFile+ }
Hbro/Socket.hs view
@@ -10,8 +10,21 @@ import System.ZMQ -- }}} -listenToSocket :: Socket Rep -> Browser -> IO a-listenToSocket repSocket browser = forever $ do+createRepSocket :: String -> Browser -> IO a+createRepSocket socketURI browser = withContext 1 $ \context -> do+ withSocket context Rep $ \repSocket -> do+ bind repSocket socketURI+ setOption repSocket (Linger 0)++ _ <- quitAdd 0 $ do+ close repSocket+ return False+ + forever $ listenToSocket repSocket browser+++listenToSocket :: Socket Rep -> Browser -> IO ()+listenToSocket repSocket browser = do command <- receive repSocket [] case unpack command of
Hbro/Types.hs view
@@ -30,11 +30,11 @@ data Configuration = Configuration { mHomePage :: String, -- ^ Startup page - mSocketDir :: String, -- ^ Path to socket directory ("/tmp" for example)+ mSocketDir :: String, -- ^ Directory where 0MQ will be created ("/tmp" for example) mUIFile :: String, -- ^ Path to XML file describing UI (used by GtkBuilder)- mKeyBindings :: KeyBindingsList, -- ^ List of keybindings- mWebSettings :: IO WebSettings, -- ^ Web settings- mAtStartUp :: Browser -> IO (), -- ^ Custom startup instructions+ mKeys :: KeysList, -- ^ List of keybindings+ mWebSettings :: IO WebSettings, -- ^ Web settings provided by webkit (see Webkit::WebSettings documentation)+ mSetup :: Browser -> IO (), -- ^ Custom startup instructions mError :: Maybe String -- ^ Error } @@ -49,4 +49,11 @@ mBuilder :: Builder -- ^ Builder object created from XML file } -type KeyBindingsList = [(([Modifier], String), (Browser -> IO ()))]+-- | List of bound keys+-- All callbacks are fed with the Browser instance+-- 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+type KeysList = [(([Modifier], String), (Browser -> IO ()))]
Hbro/Util.hs view
@@ -13,7 +13,7 @@ instance Ord Modifier where m <= m' = fromEnum m <= fromEnum m' --- {{{ Keybindings functions+-- {{{ Keys-related functions -- | Converts a keyVal to a String. -- For printable characters, the corresponding String is returned, except for the space character for which "<Space>" is returned. -- For non-printable characters, the corresponding keyName between <> is returned.@@ -35,14 +35,15 @@ "Menu" -> Nothing "ISO_Level3_Shift" -> Nothing "dead_circumflex" -> Just "^"+ "dead_diaeresis" -> Just "¨" x -> Just ('<':x ++ ">") --- | Converts key bindings list to a map.--- | Calls importKeyBindings'.+-- | Convert key bindings list to a map.+-- Calls importKeyBindings'. importKeyBindings :: [(([Modifier], String), (Browser -> IO ()))] -> Map.Map (Set.Set Modifier, String) (Browser -> IO ()) importKeyBindings list = Map.fromList $ importKeyBindings' list --- | Converts modifiers list to modifiers sets.+-- | Convert modifiers list to modifiers sets. -- The order of modifiers in key bindings don't matter. -- Called by importKeyBindings. importKeyBindings' :: [(([Modifier], String), (Browser -> IO ()))] -> [((Set.Set Modifier, String), (Browser -> IO ()))]
− examples/Main.hs
@@ -1,441 +0,0 @@-module Main where---- {{{ Imports-import Hbro.Core -import Hbro.Gui -import Hbro.Types-import Hbro.Util --import Control.Concurrent-import Control.Monad.Trans(liftIO)--import Graphics.Rendering.Pango.Layout--import Graphics.UI.Gtk.Abstract.Widget-import Graphics.UI.Gtk.Builder-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.WebNavigationAction-import Graphics.UI.Gtk.WebKit.WebView-import Graphics.UI.Gtk.WebKit.WebSettings-import Graphics.UI.Gtk.Windows.Window---- Remove this line in your custom hbro.hs-import Paths_hbro--import System.Environment-import System.Glib.Attributes-import System.Glib.Signals-import System.Process -import System.Posix.Process--- }}}--main :: IO ()-main = do- -- All lines containing "getDataFileName" won't compile- -- in your custom configuration file, you must remove them- uiFile <- getDataFileName "examples/ui.xml"- bookmarksHandlerFile <- getDataFileName "examples/scripts/bookmarks.sh"-- configHome <- getEnv "XDG_CONFIG_HOME"- - hbro Configuration {- -- Do not change this- mError = Nothing,-- -- Directory where 0MQ sockets will be created- mSocketDir = socketDir,-- -- XML file defining UI (used by GtkBuilder) - -- In your custom hbro.hs, remove the first line and use instead the second one- mUIFile = uiFile,- --mUIFile = configHome ++ "/hbro/ui.xml",-- -- URI to load at startup- mHomePage = "https://www.google.com",--- -- Custom keys- -- All callbacks are fed with the GUI instance- -- 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 3 : 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"), stopLoading),- (([], "<F5>"), reload True),- (([Shift], "<F5>"), reload False),- (([Control], "r"), reload True),- (([Control, Shift], "R"), reload False),- (([], "^"), horizontalHome),- (([], "$"), horizontalEnd),- (([], "<Home>"), verticalHome),- (([], "<End>"), verticalEnd),- (([Control], "<Home>"), goHome),-- -- Display- (([Control, Shift], "+"), zoomIn),- (([Control], "-"), zoomOut),- (([], "<F11>"), fullscreen),- (([], "<Escape>"), unfullscreen),- (([Control], "t"), toggleStatusBar),- (([Control], "u"), toggleSourceMode),-- -- 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 bookmarksHandlerFile),- (([Control, Shift], "D"), addAllInstancesToBookmarks bookmarksHandlerFile),- (([Alt], "d"), deleteTagFromBookmarks bookmarksHandlerFile),- (([Control], "l"), loadFromBookmarks bookmarksHandlerFile),- (([Control, Shift], "L"), loadTagFromBookmarks bookmarksHandlerFile),-- -- Others- (([Control], "i"), showWebInspector),- (([Control], "p"), printPage),- (([Control], "n"), newWindow)- ],--- -- 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 = \browser -> (let- builder = mBuilder (mGUI browser)- webView = mWebView (mGUI browser)- scrollWindow = mScrollWindow (mGUI browser)- window = mWindow (mGUI browser)- in do- progressLabel <- builderGetObject builder castToLabel "progress"- uriLabel <- builderGetObject builder castToLabel "uri"- scrollLabel <- builderGetObject builder castToLabel "scroll"- keysLabel <- builderGetObject builder castToLabel "keys"-- -- 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) ++ "%"-- -- Pressed keys in statusbar- _ <- after webView keyPressEvent $ do- value <- eventKeyVal- modifiers <- eventModifier-- let keyString = keyToString value- case keyString of - Just string -> liftIO $ labelSetMarkup keysLabel $ "<span foreground=\"green\">" ++ show modifiers ++ escapeMarkup string ++ "</span>"- _ -> return ()-- return False--- -- 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 uriLabel $ "<span weight=\"bold\" foreground=\"white\">" ++ escapeMarkup uri ++ "</span>"- _ -> labelSetMarkup uriLabel "<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>"-- _ <- 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--- -- History handler- _ <- on webView loadFinished $ \_ -> do- getUri <- webViewGetUri webView- getTitle <- webViewGetTitle webView- case (getUri, getTitle) of- (Just uri, Just title) -> historyHandler uri title- _ -> return ()--- -- 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 -u \"" ++ 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 -u " ++ 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 uriLabel $ "<span foreground=\"#5555ff\">" ++ escapeMarkup u ++ "</span>"- (_, Just u) -> labelSetMarkup uriLabel $ "<span foreground=\"white\" weight=\"bold\">" ++ escapeMarkup u ++ "</span>"- _ -> putStrLn "FIXME"-- - -- Favicon- --_ <- on webView iconLoaded $ \uri -> do something-- return ()- )}----- Definitions- where- -- Constants- scriptsDir, socketDir :: String- scriptsDir = "~/.config/hbro/scripts/"- socketDir = "/tmp"-- toggleSourceMode :: Browser -> IO ()- toggleSourceMode browser = do- currentMode <- webViewGetViewSourceMode (mWebView $ mGUI browser)- webViewSetViewSourceMode (mWebView $ mGUI browser) (not currentMode)-- toggleStatusBar :: Browser -> IO ()- toggleStatusBar browser = do- visibility <- get (mStatusBox $ mGUI browser) widgetVisible- case visibility of- False -> widgetShow (mStatusBox $ mGUI browser)- _ -> widgetHide (mStatusBox $ mGUI browser)--- promptURL :: Bool -> Browser -> IO() - promptURL False browser = - prompt "Open URL" "" False browser (\b -> do - uri <- entryGetText (mPromptEntry $ mGUI b)- loadURL uri b)- promptURL _ browser = do- uri <- webViewGetUri (mWebView $ mGUI browser)- case uri of- Just url -> prompt "Open URL" url False browser (\b -> do- u <- entryGetText (mPromptEntry $ mGUI b)- loadURL u b)- _ -> return ()-- promptFind :: Bool -> Bool -> Bool -> Browser -> IO ()- promptFind caseSensitive forward wrap browser =- prompt "Search" "" True browser (\browser' -> do- keyWord <- entryGetText (mPromptEntry $ mGUI browser')- found <- webViewSearchText (mWebView $ mGUI browser) keyWord caseSensitive forward wrap- return ())-- findNext :: Bool -> Bool -> Bool -> Browser -> IO ()- findNext caseSensitive forward wrap browser = do- keyWord <- entryGetText (mPromptEntry $ mGUI browser)- found <- webViewSearchText (mWebView $ mGUI browser) keyWord caseSensitive forward wrap - return ()-- newWindow :: Browser -> IO ()- newWindow browser = runExternalCommand ("hbro")-- -- Copy/paste- copyUri, copyTitle, pasteUri :: Browser -> IO()- copyUri browser = do- getUri <- webViewGetUri (mWebView $ mGUI browser)- case getUri of- Just u -> runCommand ("echo -n " ++ u ++ " | xclip") >> return ()- _ -> return ()-- copyTitle browser = do- getTitle <- webViewGetTitle (mWebView $ mGUI browser)- case getTitle of- Just t -> runCommand ("echo -n " ++ t ++ " | xclip") >> return ()- _ -> return ()-- pasteUri browser = do- uri <- readProcess "xclip" ["-o"] []- loadURL uri browser--- -- Scrolling- verticalHome, verticalEnd, horizontalHome, horizontalEnd :: Browser -> IO()- verticalHome browser = do- adjustment <- scrolledWindowGetVAdjustment (mScrollWindow $ mGUI browser)- lower <- adjustmentGetLower adjustment-- adjustmentSetValue adjustment lower-- verticalEnd browser = do- adjustment <- scrolledWindowGetVAdjustment (mScrollWindow $ mGUI browser)- upper <- adjustmentGetUpper adjustment-- adjustmentSetValue adjustment upper-- horizontalHome browser = do- adjustment <- scrolledWindowGetHAdjustment (mScrollWindow $ mGUI browser)- lower <- adjustmentGetLower adjustment-- adjustmentSetValue adjustment lower-- horizontalEnd browser = do- adjustment <- scrolledWindowGetHAdjustment (mScrollWindow $ mGUI browser)- 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, addAllInstancesToBookmarks, loadFromBookmarks :: FilePath -> Browser -> IO()- addToBookmarks handlerPath browser = do- getUri <- webViewGetUri (mWebView $ mGUI browser)- case getUri of- Just uri -> prompt "Bookmark with tag:" "" False browser (\b -> do - tags <- entryGetText (mPromptEntry $ mGUI b)- runExternalCommand $ handlerPath ++ " add " ++ uri ++ " " ++ tags)- --runExternalCommand $ scriptsDir ++ "bookmarks.sh add " ++ uri ++ " " ++ tags)- _ -> return ()-- addAllInstancesToBookmarks handlerPath browser = do- prompt "Bookmark all instances with tag:" "" False browser (\b -> do - tags <- entryGetText (mPromptEntry $ mGUI b)- _ <- forkIO $ (runCommand (handlerPath ++ " add-all " ++ socketDir ++ " " ++ tags)) >> return ()- --_ <- forkIO $ (runCommand (scriptsDir ++ "bookmarks.sh add-all " ++ socketDir ++ " " ++ tags)) >> return ()- return())-- loadFromBookmarks handlerPath browser = do - pid <- getProcessID- runExternalCommand $ handlerPath ++ " load \"" ++ socketDir ++ "/hbro." ++ show pid ++ "\""- --runExternalCommand $ scriptsDir ++ "bookmarks.sh load \"" ++ socketDir ++ "/hbro." ++ show pid ++ "\""-- loadTagFromBookmarks handlerPath browser = do- runExternalCommand $ handlerPath ++ " load-tag"- --runExternalCommand $ scriptsDir ++ "bookmarks.sh load-tag"-- deleteTagFromBookmarks handlerPath browser = do- runExternalCommand $ handlerPath ++ " delete-tag"- --runExternalCommand $ scriptsDir ++ "bookmarks.sh delete-tag"
+ examples/hbro.hs view
@@ -0,0 +1,287 @@+module Main where++-- {{{ Imports+import Hbro.Config+import Hbro.Core+import Hbro.Extra+import Hbro.Gui+import Hbro.Types+import Hbro.Util++import Control.Concurrent++--import Graphics.Rendering.Pango.Layout++import Graphics.UI.Gtk.Abstract.Widget+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.WebNavigationAction+import Graphics.UI.Gtk.WebKit.WebSettings+import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.Windows.Window++import System.Environment+import System.Glib.Attributes+import System.Glib.Signals+import System.Posix.Process+import System.Process +-- }}}++main :: IO ()+main = do+ configHome <- getEnv "XDG_CONFIG_HOME"++ -- See Types::Configuration documentation for fields description+ -- Commented out fields indicated default values+ hbro defaultConfiguration {+ --mSocketDir = "/tmp/",+ mUIFile = configHome ++ "/hbro/ui.xml",+ --mHomePage = "https://www.google.com",+ mKeys = myKeys,+ mWebSettings = myWebSettings,+ mSetup = mySetup+ }+++-- {{{ Keys+myKeys :: KeysList+myKeys = generalKeys ++ bookmarksKeys++generalKeys :: KeysList+generalKeys = [+ -- ((modifiers, key), callback)+ -- Browse+ (([], "<"), goBack),+ (([Shift], ">"), goForward),+ (([Control], "s"), stopLoading),+ (([], "<F5>"), reload True),+ (([Shift], "<F5>"), reload False),+ (([Control], "r"), reload True),+ (([Control, Shift], "R"), reload False),+ (([Control], "^"), horizontalHome),+ (([Control], "$"), horizontalEnd),+ (([Control], "<Home>"), verticalHome),+ (([Control], "<End>"), verticalEnd),+ (([Alt], "<Home>"), goHome),++ -- Display+ (([Control, Shift], "+"), zoomIn),+ (([Control], "-"), zoomOut),+ (([], "<F11>"), fullscreen),+ (([], "<Escape>"), unfullscreen),+ (([Control], "b"), toggleStatusBar),+ (([Control], "u"), toggleSourceMode),++ -- Prompt+ (([Control], "o"), promptURL False), + (([Control, Shift], "O"), promptURL True),++ -- Search+ (([Shift], "/"), promptFind False True True),+ (([Shift], "?"), promptFind False False True),+ (([Control], "n"), findNext False True True),+ (([Control, Shift], "N"), findNext False False True),++ -- Copy/paste+ (([Control], "y"), copyUri),+ (([Control, Shift], "Y"), copyTitle),+ --(([], "p"), loadURIFromClipboard), -- /!\ UNSTABLE, can't see why...++ -- Others+ (([Control], "i"), showWebInspector),+ (([Control], "p"), printPage),+ (([Control], "t"), newWindow)+ ]+-- }}}++-- {{{ Web settings+-- Commented lines correspond to default values+myWebSettings :: IO WebSettings+myWebSettings = 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 Firefox"+ --webSettingsUserStylesheetUri := Nothing,+ --webSettingsZoomStep := 0.1+ ]+ return settings+-- }}}++-- {{{ Setup+mySetup :: Browser -> IO ()+mySetup browser = + let+ builder = mBuilder (mGUI browser)+ webView = mWebView (mGUI browser)+ scrollWindow = mScrollWindow (mGUI browser)+ window = mWindow (mGUI browser)+ in do+ -- Default background (for status bar)+ widgetModifyBg window StateNormal (Color 0 0 10000)+ + -- Status bar+ statusBarScrollPosition browser+ statusBarPressedKeys browser+ statusBarLoadProgress browser+ statusBarURI browser++ _ <- 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+++ -- History handler+ _ <- on webView loadFinished $ \_ -> do+ getUri <- webViewGetUri webView+ getTitle <- webViewGetTitle webView+ case (getUri, getTitle) of+ (Just uri, Just title) -> historyHandler uri title+ _ -> return ()+++ -- 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 -u \"" ++ 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 -u \"" ++ uri ++ "\""+ _ -> putStrLn "ERROR: wrong URI given, unable to open window."++ return True++ -- Favicon+ --_ <- on webView iconLoaded $ \uri -> do something++ return ()+-- }}}+ +-- {{{ Handlers+downloadHandler :: String -> IO ()+downloadHandler uri = runExternalCommand $ "wget \"" ++ uri ++ "\""++historyHandler :: String -> String -> IO ()+historyHandler uri title = do+ configHome <- getEnv "XDG_CONFIG_HOME"+ runCommand (configHome ++ "/hbro/scripts/historyHandler.sh \"" ++ uri ++ "\" \"" ++ title ++ "\"") >> return ()+-- }}}++-- {{{ Bookmarks+bookmarksKeys :: KeysList+bookmarksKeys = [+-- ((modifiers, key), callback)+ (([Control], "d"), addToBookmarks),+ (([Control, Shift], "D"), addAllInstancesToBookmarks),+ (([Alt], "d"), deleteTagFromBookmarks),+ (([Control], "l"), loadFromBookmarks),+ (([Control, Shift], "L"), loadTagFromBookmarks)+ ]++addToBookmarks, addAllInstancesToBookmarks, loadFromBookmarks, loadTagFromBookmarks, deleteTagFromBookmarks :: Browser -> IO ()++addToBookmarks browser = do+ getUri <- webViewGetUri (mWebView $ mGUI browser)+ configHome <- getEnv "XDG_CONFIG_HOME"+ case getUri of+ Just uri -> prompt "Bookmark with tag:" "" False browser (\b -> do + tags <- entryGetText (mPromptEntry $ mGUI b)+ runExternalCommand $ configHome ++ "/hbro/scripts/bookmarks.sh add \"" ++ uri ++ "\" " ++ tags)+ _ -> return ()++addAllInstancesToBookmarks browser = do+ configHome <- getEnv "XDG_CONFIG_HOME"+ prompt "Bookmark all instances with tag:" "" False browser (\b -> do + tags <- entryGetText (mPromptEntry $ mGUI b)+ _ <- forkIO $ (runCommand (configHome ++ "/hbro/scripts/bookmarks.sh add-all " ++ (mSocketDir $ mConfiguration browser) ++ " " ++ tags)) >> return ()+ return())++loadFromBookmarks browser = do + pid <- getProcessID+ configHome <- getEnv "XDG_CONFIG_HOME"+ runExternalCommand $ configHome ++ "/hbro/scripts/bookmarks.sh load \"" ++ (mSocketDir $ mConfiguration browser) ++ "/hbro." ++ show pid ++ "\""++loadTagFromBookmarks browser = do+ configHome <- getEnv "XDG_CONFIG_HOME"+ runExternalCommand $ configHome ++ "/hbro/scripts/bookmarks.sh load-tag"++deleteTagFromBookmarks browser = do+ configHome <- getEnv "XDG_CONFIG_HOME"+ runExternalCommand $ configHome ++ "/hbro/scripts/bookmarks.sh delete-tag"+-- }}}
hbro.cabal view
@@ -1,5 +1,5 @@ Name: hbro-Version: 0.5.3+Version: 0.6.0 Synopsis: A suckless minimal KISSy browser -- Description: Homepage: http://projects.haskell.org/hbro/@@ -14,7 +14,7 @@ Cabal-version: >=1.8 Build-type: Simple-Extra-source-files: examples/Main.hs+Extra-source-files: examples/hbro.hs Data-files: examples/ui.xml, examples/scripts/bookmarks.sh@@ -33,19 +33,23 @@ glib, gtk, mtl,+ pango, process, url, webkit, unix, zeromq-haskell Exposed-modules:+ Hbro.Config, Hbro.Core,+ Hbro.Extra, Hbro.Gui, Hbro.Socket, Hbro.Types, Hbro.Util Ghc-options: -Wall + Executable hbro Build-depends: hbro,@@ -58,6 +62,6 @@ unix, webkit Main-is: Main.hs- Hs-Source-Dirs: examples + Hs-Source-Dirs: Hbro Ghc-options: -Wall -threaded