diff --git a/Hbro/Config.hs b/Hbro/Config.hs new file mode 100644 --- /dev/null +++ b/Hbro/Config.hs @@ -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 +} diff --git a/Hbro/Core.hs b/Hbro/Core.hs --- a/Hbro/Core.hs +++ b/Hbro/Core.hs @@ -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") -- }}} diff --git a/Hbro/Extra.hs b/Hbro/Extra.hs new file mode 100644 --- /dev/null +++ b/Hbro/Extra.hs @@ -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 $ "" ++ show modifiers ++ escapeMarkup string ++ "" + _ -> 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 "0%" + + _ <- on webView progressChanged $ \progress' -> + labelSetMarkup progressLabel $ "" ++ show progress' ++ "%" + + _ <- on webView loadFinished $ \_ -> do + labelSetMarkup progressLabel "100%" + + _ <- on webView loadError $ \_ _ _ -> do + labelSetMarkup progressLabel "ERROR" + 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 $ "" ++ escapeMarkup uri ++ "" + _ -> labelSetMarkup uriLabel "ERROR" + + _ <- on webView hoveringOverLink $ \title hoveredUri -> do + getUri <- (webViewGetUri webView) + case (hoveredUri, getUri) of + (Just u, _) -> labelSetMarkup uriLabel $ "" ++ escapeMarkup u ++ "" + (_, Just u) -> labelSetMarkup uriLabel $ "" ++ escapeMarkup u ++ "" + _ -> 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 +-- }}} diff --git a/Hbro/Gui.hs b/Hbro/Gui.hs --- a/Hbro/Gui.hs +++ b/Hbro/Gui.hs @@ -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) +-- }}} diff --git a/Hbro/Main.hs b/Hbro/Main.hs new file mode 100644 --- /dev/null +++ b/Hbro/Main.hs @@ -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 + } diff --git a/Hbro/Socket.hs b/Hbro/Socket.hs --- a/Hbro/Socket.hs +++ b/Hbro/Socket.hs @@ -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 diff --git a/Hbro/Types.hs b/Hbro/Types.hs --- a/Hbro/Types.hs +++ b/Hbro/Types.hs @@ -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 ()))] diff --git a/Hbro/Util.hs b/Hbro/Util.hs --- a/Hbro/Util.hs +++ b/Hbro/Util.hs @@ -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 "" 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 ()))] diff --git a/examples/Main.hs b/examples/Main.hs deleted file mode 100644 --- a/examples/Main.hs +++ /dev/null @@ -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), - (([], ""), reload True), - (([Shift], ""), reload False), - (([Control], "r"), reload True), - (([Control, Shift], "R"), reload False), - (([], "^"), horizontalHome), - (([], "$"), horizontalEnd), - (([], ""), verticalHome), - (([], ""), verticalEnd), - (([Control], ""), goHome), - - -- Display - (([Control, Shift], "+"), zoomIn), - (([Control], "-"), zoomOut), - (([], ""), fullscreen), - (([], ""), 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 $ "" ++ show modifiers ++ escapeMarkup string ++ "" - _ -> return () - - return False - - - -- Page load - _ <- on webView loadStarted $ \_ -> do - labelSetMarkup progressLabel "0%" - - _ <- on webView loadCommitted $ \_ -> do - getUri <- (webViewGetUri webView) - case getUri of - Just uri -> labelSetMarkup uriLabel $ "" ++ escapeMarkup uri ++ "" - _ -> labelSetMarkup uriLabel "ERROR" - - _ <- on webView progressChanged $ \progress' -> - labelSetMarkup progressLabel $ "" ++ show progress' ++ "%" - - _ <- on webView loadFinished $ \_ -> do - labelSetMarkup progressLabel "100%" - - _ <- on webView loadError $ \_ _ _ -> do - labelSetMarkup progressLabel "ERROR" - 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 $ "" ++ escapeMarkup u ++ "" - (_, Just u) -> labelSetMarkup uriLabel $ "" ++ escapeMarkup u ++ "" - _ -> 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" diff --git a/examples/hbro.hs b/examples/hbro.hs new file mode 100644 --- /dev/null +++ b/examples/hbro.hs @@ -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), + (([], ""), reload True), + (([Shift], ""), reload False), + (([Control], "r"), reload True), + (([Control, Shift], "R"), reload False), + (([Control], "^"), horizontalHome), + (([Control], "$"), horizontalEnd), + (([Control], ""), verticalHome), + (([Control], ""), verticalEnd), + (([Alt], ""), goHome), + + -- Display + (([Control, Shift], "+"), zoomIn), + (([Control], "-"), zoomOut), + (([], ""), fullscreen), + (([], ""), 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" +-- }}} diff --git a/hbro.cabal b/hbro.cabal --- a/hbro.cabal +++ b/hbro.cabal @@ -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