diff --git a/Hbro/Config.hs b/Hbro/Config.hs --- a/Hbro/Config.hs +++ b/Hbro/Config.hs @@ -9,6 +9,7 @@ import Graphics.UI.Gtk.WebKit.WebSettings -- }}} + -- {{{ Dyre showError :: Configuration -> String -> Configuration showError configuration message = configuration { mError = Just message } @@ -21,6 +22,7 @@ Dyre.ghcOpts = ["-threaded"] } -- }}} + -- | Default configuration. -- Does quite nothing. diff --git a/Hbro/Core.hs b/Hbro/Core.hs --- a/Hbro/Core.hs +++ b/Hbro/Core.hs @@ -22,13 +22,13 @@ import Graphics.UI.Gtk.WebKit.WebFrame import Network.URL -import Prelude import System.Console.CmdArgs import System.Glib.Signals import System.Posix.Process -- }}} + -- {{{ Commandline options cliOptions :: CliOptions cliOptions = CliOptions{ @@ -44,8 +44,9 @@     &= program "hbro" -- }}} + -- {{{ Entry point --- | Entry point of the application. +-- | Entry point for the application. -- Parse arguments and step down in favour of initBrowser. -- Print configuration error, if any. realMain :: Configuration -> IO () @@ -58,6 +59,7 @@ initBrowser configuration options -- }}} + -- {{{ Main function -- | Application's main function. @@ -70,6 +72,11 @@ let browser = Browser options configuration gui let webView = mWebView gui + -- Load addtionnal settings from configuration + settings <- mWebSettings configuration + webViewSetWebSettings webView settings + (mSetup configuration) browser + -- Initialize IPC socket pid <- getProcessID let socketURI = "ipc://" ++ (mSocketDir configuration) ++ "/hbro." ++ show pid @@ -77,11 +84,6 @@ _ <- forkIO $ createRepSocket socketURI browser - -- Load configuration - settings <- mWebSettings configuration - webViewSetWebSettings webView settings - (mSetup configuration) browser - -- Load homepage goHome browser @@ -104,6 +106,7 @@ let keyString = keyToString value case keyString of + Just "" -> liftIO $ showPrompt False browser Just string -> do case Map.lookup (Set.fromList modifiers, string) keyBindings of Just callback -> liftIO $ callback browser @@ -120,38 +123,32 @@ mainGUI -- }}} --- {{{ Util functions -goHome, goBack, goForward, stopLoading :: Browser -> IO () --- | Wrapper around webViewGoBack function -goBack browser = webViewGoBack (mWebView $ mGUI browser) --- | Wrapper around webViewGoForward function -goForward browser = webViewGoForward (mWebView $ mGUI browser) --- | Wrapper around webViewStopLoading function -stopLoading browser = webViewStopLoading (mWebView $ mGUI browser) +-- {{{ Browse -- | Load homepage (retrieved from commandline options or configuration file) -goHome browser = case (mURI $ mOptions browser) of +goHome :: Browser -> IO () +goHome browser = case (mURI $ mOptions browser) of Just uri -> loadURL uri browser _ -> loadURL (mHomePage $ mConfiguration browser) browser +-- | Wrapper around webViewGoBack function +goBack :: Browser -> IO () +goBack browser = webViewGoBack (mWebView $ mGUI browser) + +-- | Wrapper around webViewGoForward function +goForward :: Browser -> IO () +goForward browser = webViewGoForward (mWebView $ mGUI browser) + +-- | Wrapper around webViewStopLoading function +stopLoading :: Browser -> IO () +stopLoading browser = webViewStopLoading (mWebView $ mGUI browser) + -- | Wrapper around webViewReload{BypassCache} -- If boolean argument is False, it bypasses the cache reload :: Bool -> Browser -> IO() reload True browser = webViewReload (mWebView $ mGUI browser) reload _ browser = webViewReloadBypassCache (mWebView $ mGUI browser) -zoomIn, zoomOut :: Browser -> IO() --- | Wrapper around webViewZoomIn function -zoomIn browser = webViewZoomIn (mWebView $ mGUI browser) --- | Wrapper around webViewZoomOut function -zoomOut browser = webViewZoomOut (mWebView $ mGUI browser) - --- | Wrapper around webFramePrint function -printPage :: Browser -> IO() -printPage browser = do - frame <- webViewGetMainFrame (mWebView $ mGUI browser) - webFramePrint frame - -- | Load given URL in the browser. loadURL :: String -> Browser -> IO () loadURL url browser = @@ -167,34 +164,63 @@ 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 +-- }}} --- Scrolling functions -verticalHome, verticalEnd, horizontalHome, horizontalEnd :: Browser -> IO () + +-- {{{ Zoom +-- | Wrapper around webViewZoomIn function +zoomIn :: Browser -> IO () +zoomIn browser = webViewZoomIn (mWebView $ mGUI browser) + +-- | Wrapper around webViewZoomOut function +zoomOut :: Browser -> IO () +zoomOut browser = webViewZoomOut (mWebView $ mGUI browser) +-- }}} + + +-- | Wrapper around webFramePrint function, provided for convenience. +printPage :: Browser -> IO() +printPage browser = do + frame <- webViewGetMainFrame (mWebView $ mGUI browser) + webFramePrint frame + + +-- {{{ Scrolling +-- | Scroll up to top of web page. Provided for convenience. +verticalHome :: Browser -> IO () verticalHome browser = do adjustment <- scrolledWindowGetVAdjustment (mScrollWindow $ mGUI browser) lower <- adjustmentGetLower adjustment adjustmentSetValue adjustment lower + +-- | Scroll down to bottom of web page. Provided for convenience. +verticalEnd :: Browser -> IO () verticalEnd browser = do adjustment <- scrolledWindowGetVAdjustment (mScrollWindow $ mGUI browser) upper <- adjustmentGetUpper adjustment adjustmentSetValue adjustment upper +-- | +horizontalHome :: Browser -> IO () horizontalHome browser = do adjustment <- scrolledWindowGetHAdjustment (mScrollWindow $ mGUI browser) lower <- adjustmentGetLower adjustment adjustmentSetValue adjustment lower +-- | +horizontalEnd :: Browser -> IO () horizontalEnd browser = do adjustment <- scrolledWindowGetHAdjustment (mScrollWindow $ mGUI browser) upper <- adjustmentGetUpper adjustment adjustmentSetValue adjustment upper +-- }}} --- | Spawn a new instance of the browser + +-- | Spawn a new instance of the browser. newWindow :: Browser -> IO () -newWindow browser = runExternalCommand ("hbro") --- }}} +newWindow browser = runExternalCommand "hbro" diff --git a/Hbro/Extra.hs b/Hbro/Extra.hs deleted file mode 100644 --- a/Hbro/Extra.hs +++ /dev/null @@ -1,193 +0,0 @@ -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.General.Clipboard -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) - primaryClip <- widgetGetClipboard (mWindow $ mGUI browser) selectionPrimary - - case getUri of - Just u -> clipboardSetText primaryClip u - _ -> return () - --- | Copy current page title in clipboard. -copyTitle browser = do - getTitle <- webViewGetTitle (mWebView $ mGUI browser) - primaryClip <- widgetGetClipboard (mWindow $ mGUI browser) selectionPrimary - - case getTitle of - Just t -> clipboardSetText primaryClip t - _ -> return () - --- | Load URI from clipboard. Does not work for now... -loadURIFromClipboard browser = do - primaryClip <- widgetGetClipboard (mWindow $ mGUI browser) selectionPrimary - - _ <- clipboardRequestText primaryClip $ \x -> case x of - Just uri -> putStrLn ("Loading URI from clipboard: " ++ uri) >> loadURL uri browser - _ -> putStrLn "Loading URI from clipboard: empty clipboard." - return () --- }}} - --- {{{ 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/Extra/Bookmarks.hs b/Hbro/Extra/Bookmarks.hs new file mode 100644 --- /dev/null +++ b/Hbro/Extra/Bookmarks.hs @@ -0,0 +1,151 @@ +module Hbro.Extra.Bookmarks where + +-- {{{ Imports +import Hbro.Core +import Hbro.Gui +import Hbro.Types +import Hbro.Util + +import Data.ByteString.Char8 (pack, unpack) +import Data.List + +import Graphics.UI.Gtk.Entry.Entry +import Graphics.UI.Gtk.WebKit.WebView + +import System.Environment +import System.Exit +import qualified System.Info as Sys +import System.Posix.Process +import System.Process +import System.ZMQ +-- }}} + + +-- +addToBookmarks :: Browser -> IO () +addToBookmarks browser = do + uri <- webViewGetUri (mWebView $ mGUI browser) + + case uri of + Just u -> prompt "Bookmark with tag:" "" False browser (\b -> do + tags <- entryGetText (mPromptEntry $ mGUI b) + bookmark u (words tags)) + _ -> return () + +-- +addAllInstancesToBookmarks :: Browser -> IO () +addAllInstancesToBookmarks browser = + prompt "Bookmark all instances with tag:" "" False browser (\b -> do + tags <- entryGetText (mPromptEntry $ mGUI b) + (_, pids, _) <- readProcessWithExitCode "pidof" ["hbro"] [] + (_, pids', _) <- readProcessWithExitCode "pidof" ["hbro-" ++ Sys.os ++ "-" ++ Sys.arch] [] + myPid <- getProcessID + + let pidsList = delete (show myPid) . nub . words $ pids ++ " " ++ pids' + let bookmarkPID = (\pid -> withContext 1 $ \context -> do + withSocket context Req $ \reqSocket -> + let + socketURI = "ipc://" ++ (mSocketDir $ mConfiguration browser) ++ "/hbro." ++ pid + in do + connect reqSocket socketURI + + send reqSocket (pack "getUri") [] + uri <- receive reqSocket [] + + bookmark (unpack uri) (words tags) + ) + + _ <- mapM bookmarkPID pidsList + return ()) + +-- | +loadFromBookmarks :: Browser -> IO () +loadFromBookmarks browser = do + configHome <- getEnv "XDG_CONFIG_HOME" + file <- readFile $ configHome ++ "/hbro/bookmarks" + + let file' = unlines . sort . nub $ map reformat (lines file) + + (code, result, e) <- readProcessWithExitCode "dmenu" ["-l", "10"] file' + case (code, result) of + (ExitSuccess, r) -> + let + uri:_ = reverse . words $ r + in + loadURL uri browser + _ -> putStrLn e + + where + reformat line = + let + uri:tags = words line + tags' = sort $ map (\tag -> "[" ++ tag ++ "]") tags + in + unwords $ tags' ++ [uri] + +-- | +loadTagFromBookmarks :: Browser -> IO () +loadTagFromBookmarks browser = do + configHome <- getEnv "XDG_CONFIG_HOME" + file <- readFile $ configHome ++ "/hbro/bookmarks" + + let list = unlines . sort . nub . words . unwords $ map getTags (lines file) + + (code, result, e) <- readProcessWithExitCode "dmenu" [] list + case (code, result) of + (ExitSuccess, tag) -> + let + file' = filter (tagFilter tag) (lines file) + uris = map getUri file' + in do + _ <- mapM (\uri -> runExternalCommand ("hbro -u \"" ++ uri ++ "\"")) uris + return () + + _ -> putStrLn e + + where + tagFilter tag line = let uri:tags = words line in case (intersect [tag] tags) of + [t] -> True + _ -> False + + +-- | +deleteTagFromBookmarks :: Browser -> IO () +deleteTagFromBookmarks browser = do + configHome <- getEnv "XDG_CONFIG_HOME" + file <- readFile $ configHome ++ "/hbro/bookmarks" + + let tagsList = unlines . sort . nub . words . unwords $ map getTags (lines file) + + (code, result, e) <- readProcessWithExitCode "dmenu" [] tagsList + case (code, result) of + (ExitSuccess, tag) -> + let + file' = unlines $ filter (tagFilter tag) (lines file) + in do + writeFile (configHome ++ "/hbro/bookmarks.old") file + writeFile (configHome ++ "/hbro/bookmarks") file' + return () + + + _ -> putStrLn e + where + tagFilter tag line = let uri:tags = words line in case (intersect [tag] tags) of + [t] -> False + _ -> True + + +-- The elementary bookmark action +bookmark :: String -> [String] -> IO () +bookmark uri tags = do + configHome <- getEnv "XDG_CONFIG_HOME" + appendFile (configHome ++ "/hbro/bookmarks") $ uri ++ " " ++ (unwords tags) ++ "\n" + +-- | +getTags :: String -> String +getTags line = let _:tags = words line in unwords tags + +-- | +getUri :: String -> String +getUri line = let uri:_ = words line in uri +-- }}} diff --git a/Hbro/Extra/Clipboard.hs b/Hbro/Extra/Clipboard.hs new file mode 100644 --- /dev/null +++ b/Hbro/Extra/Clipboard.hs @@ -0,0 +1,41 @@ +module Hbro.Extra.Clipboard where + +-- {{{ Imports +import Hbro.Core +import Hbro.Types + +import Graphics.UI.Gtk.Abstract.Widget +import Graphics.UI.Gtk.General.Clipboard +import Graphics.UI.Gtk.WebKit.WebView +-- }}} + + +-- | Copy current URI in clipboard. +copyUri :: Browser -> IO () +copyUri browser = do + getUri <- webViewGetUri (mWebView $ mGUI browser) + primaryClip <- widgetGetClipboard (mWindow $ mGUI browser) selectionPrimary + + case getUri of + Just u -> clipboardSetText primaryClip u + _ -> return () + +-- | Copy current page title in clipboard. +copyTitle :: Browser -> IO () +copyTitle browser = do + getTitle <- webViewGetTitle (mWebView $ mGUI browser) + primaryClip <- widgetGetClipboard (mWindow $ mGUI browser) selectionPrimary + + case getTitle of + Just t -> clipboardSetText primaryClip t + _ -> return () + +-- | Load URI from clipboard. Does not work for now... +loadURIFromClipboard :: Browser -> IO () +loadURIFromClipboard browser = do + primaryClip <- widgetGetClipboard (mWindow $ mGUI browser) selectionPrimary + + _ <- clipboardRequestText primaryClip $ \x -> case x of + Just uri -> putStrLn ("Loading URI from clipboard: " ++ uri) >> loadURL uri browser + _ -> putStrLn "Loading URI from clipboard: empty clipboard." + return () diff --git a/Hbro/Extra/Misc.hs b/Hbro/Extra/Misc.hs new file mode 100644 --- /dev/null +++ b/Hbro/Extra/Misc.hs @@ -0,0 +1,15 @@ +module Hbro.Extra.Misc where + +-- {{{ Imports +import Hbro.Core +import Hbro.Types + +import Graphics.UI.Gtk.WebKit.WebView +-- }}} + + +toggleSourceMode :: Browser -> IO () +toggleSourceMode browser = do + currentMode <- webViewGetViewSourceMode (mWebView $ mGUI browser) + webViewSetViewSourceMode (mWebView $ mGUI browser) (not currentMode) + reload True browser diff --git a/Hbro/Extra/Prompt.hs b/Hbro/Extra/Prompt.hs new file mode 100644 --- /dev/null +++ b/Hbro/Extra/Prompt.hs @@ -0,0 +1,40 @@ +module Hbro.Extra.Prompt where + +-- {{{ Imports +import Hbro.Core +import Hbro.Gui +import Hbro.Types + +import Graphics.UI.Gtk.Entry.Entry +import Graphics.UI.Gtk.WebKit.WebView +-- }}} + + +-- | 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 () diff --git a/Hbro/Extra/StatusBar.hs b/Hbro/Extra/StatusBar.hs new file mode 100644 --- /dev/null +++ b/Hbro/Extra/StatusBar.hs @@ -0,0 +1,121 @@ +module Hbro.Extra.StatusBar where + +-- {{{ Imports +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.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 +-- }}} + + +-- | 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) ++ "%" + + labelSetMarkup scrollLabel "0%" + --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, modifiers) of + (Just k, []) -> liftIO $ labelSetMarkup keysLabel $ "" ++ escapeMarkup k ++ "" + (Just k, m) -> liftIO $ labelSetMarkup keysLabel $ "" ++ show m ++ escapeMarkup k ++ "" + _ -> 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 () diff --git a/Hbro/Gui.hs b/Hbro/Gui.hs --- a/Hbro/Gui.hs +++ b/Hbro/Gui.hs @@ -25,6 +25,7 @@ import System.Glib.Signals -- }}} + -- | Load GUI from XML file loadGUI :: String -> IO GUI loadGUI xmlPath = do @@ -59,6 +60,7 @@ return $ GUI window inspectorWindow scrollWindow webView promptLabel promptEntry statusBox builder + -- {{{ Web inspector initWebInspector :: WebInspector -> IO (Window) initWebInspector inspector = do @@ -111,6 +113,7 @@ -- }}} + -- {{{ Prompt -- | Show or hide the prompt bar (label + entry). showPrompt :: Bool -> Browser -> IO () @@ -179,6 +182,7 @@ return () -- }}} + -- {{{ Util -- | Toggle statusbar's visibility diff --git a/Hbro/Main.hs b/Hbro/Main.hs --- a/Hbro/Main.hs +++ b/Hbro/Main.hs @@ -14,8 +14,8 @@ 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." +-- 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 @@ -6,7 +6,6 @@ import Control.Monad import Data.ByteString.Char8 (pack, unpack) -import Data.List.Split import qualified Data.Map as Map import Graphics.UI.Gtk.General.General @@ -36,7 +35,7 @@ listenToSocket :: Socket Rep -> CommandsMap -> Browser -> IO () listenToSocket repSocket commands browser = do message <- receive repSocket [] - let command:arguments = splitOn " " $ unpack message + let command:arguments = words $ unpack message case Map.lookup command commands of Just callback -> callback arguments repSocket browser diff --git a/Hbro/Types.hs b/Hbro/Types.hs --- a/Hbro/Types.hs +++ b/Hbro/Types.hs @@ -14,12 +14,11 @@ import Graphics.UI.Gtk.WebKit.WebView import Graphics.UI.Gtk.Windows.Window -import Prelude - import System.Console.CmdArgs import System.ZMQ -- }}} + data Browser = Browser { mOptions :: CliOptions, -- ^ Commandline options mConfiguration :: Configuration, -- ^ Custom configuration provided by user @@ -52,6 +51,7 @@ mStatusBox :: HBox, -- ^ Status bar's horizontal box mBuilder :: Builder -- ^ Builder object created from XML file } + -- | List of bound keys -- All callbacks are fed with the Browser instance diff --git a/examples/hbro.hs b/examples/hbro.hs --- a/examples/hbro.hs +++ b/examples/hbro.hs @@ -3,21 +3,19 @@ -- {{{ Imports import Hbro.Config import Hbro.Core -import Hbro.Extra +import Hbro.Extra.Bookmarks +import Hbro.Extra.Clipboard +import Hbro.Extra.Misc +import Hbro.Extra.Prompt +import Hbro.Extra.StatusBar 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 @@ -28,10 +26,11 @@ import System.Environment import System.Glib.Attributes import System.Glib.Signals -import System.Posix.Process +-- import System.Posix.Process import System.Process -- }}} + main :: IO () main = do configHome <- getEnv "XDG_CONFIG_HOME" @@ -68,6 +67,7 @@ (([Control], ""), verticalHome), (([Control], ""), verticalEnd), (([Alt], ""), goHome), + (([Control], "g"), promptGoogle), -- Display (([Control, Shift], "+"), zoomIn), @@ -83,6 +83,7 @@ -- Search (([Shift], "/"), promptFind False True True), + (([Control], "f"), promptFind False True True), (([Shift], "?"), promptFind False False True), (([Control], "n"), findNext False True True), (([Control, Shift], "N"), findNext False False True), @@ -97,8 +98,20 @@ (([Alt], "p"), printPage), (([Control], "t"), newWindow) ] + +bookmarksKeys :: KeysList +bookmarksKeys = [ +-- ((modifiers, key), callback) + (([Control], "d"), addToBookmarks), + (([Control, Shift], "D"), addAllInstancesToBookmarks), + (([Alt], "d"), deleteTagFromBookmarks), + (([Control], "l"), loadFromBookmarks), + (([Control, Shift], "L"), loadTagFromBookmarks) + ] + -- }}} + -- {{{ Web settings -- Commented lines correspond to default values myWebSettings :: IO WebSettings @@ -120,15 +133,15 @@ --webSettingsAutoShrinkImages := True, --webSettingsDefaultEncoding := "iso-8859-1", --webSettingsEditingBehavior := EditingBehaviorWindows, - --webSettingsEnableCaretBrowsing := , + --webSettingsEnableCaretBrowsing := False, webSettingsEnableDeveloperExtras := True, - webSettingsEnableHtml5Database := False, - webSettingsEnableHtml5LocalStorage := False, - webSettingsEnableOfflineWebApplicationCache := True, + --webSettingsEnableHtml5Database := True, + --webSettingsEnableHtml5LocalStorage := True, + --webSettingsEnableOfflineWebApplicationCache := True, webSettingsEnablePlugins := True, - webSettingsEnablePrivateBrowsing := False, + webSettingsEnablePrivateBrowsing := False, -- Experimental webSettingsEnableScripts := True, - webSettingsEnableSpellChecking := True, + --webSettingsEnableSpellChecking := False, webSettingsEnableUniversalAccessFromFileUris := True, webSettingsEnableXssAuditor := True, --webSettingsEnableSiteSpecificQuirks := False, @@ -149,6 +162,7 @@ return settings -- }}} + -- {{{ Setup mySetup :: Browser -> IO () mySetup browser = @@ -232,6 +246,7 @@ return () -- }}} + -- {{{ Handlers downloadHandler :: String -> IO () @@ -243,45 +258,11 @@ 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" +promptGoogle :: Browser -> IO () +promptGoogle browser = + prompt "Google search" "" False browser (\browser' -> do + keyWords <- entryGetText (mPromptEntry $ mGUI browser') + loadURL ("https://www.google.com/search?q=" ++ keyWords) browser' + return ()) -deleteTagFromBookmarks browser = do - configHome <- getEnv "XDG_CONFIG_HOME" - runExternalCommand $ configHome ++ "/hbro/scripts/bookmarks.sh delete-tag" --- }}} diff --git a/examples/scripts/bookmarks.sh b/examples/scripts/bookmarks.sh deleted file mode 100644 --- a/examples/scripts/bookmarks.sh +++ /dev/null @@ -1,90 +0,0 @@ -#!/bin/sh - -DMENU_OPTIONS="-l 10" -DMENU_COLORS="-nb #000033 -nf #ccccff -sb #0000ff -sf #ffff00" -BOOKMARKS_FILE="$XDG_CONFIG_HOME/hbro/bookmarks" -BROWSER="hbro" -SCRIPT_PATH="$0" -ACTION="$1" - - -case $ACTION in - # Add current page to bookmarks - "add" ) - # Not enough arguments - if [ $# -lt 3 ]; then - echo "Not enough argument." - exit 1 - fi - - URI="$2" - TAGS=$(echo $* | cut -d' ' -f3-) - - echo -e "$URI $TAGS" >> $BOOKMARKS_FILE - ;; - - # Add all currently opened pages to bookmarks - "add-all" ) - # Not enough arguments - if [ $# -lt 3 ]; then - echo "Not enough argument." - exit 1 - fi - - SOCKET_DIR="$2" - TAGS=$(echo $* | cut -d' ' -f3-) - - for PID in `pidof hbro`; do - SOCKET="$SOCKET_DIR/hbro.$PID" - URI=`zmqat -req "ipc://$SOCKET" "getUri"` - echo -e "$URI $TAGS" >> $BOOKMARKS_FILE - done - ;; - - # Delete all bookmarks with given tag - "delete-tag" ) - TAG=$(awk '{for (i = 2; i <= NF; i++) print $i; }' "$BOOKMARKS_FILE" | sort -bfu | dmenu $DMENU_OPTIONS $DMENU_COLORS -p "Delete bookmarks tag:") - - if [ -n "$TAG" ]; then - sed -i".bak" '/ '$TAG'/d' "$BOOKMARKS_FILE" - fi - ;; - - # Load a single bookmark - "load" ) - # Not enough arguments - if [ $# -lt 2 ]; then - echo "Not enough argument." - exit 1 - fi - - SOCKET=$2 - URI=$(sed -e 's/%/%%/g' "$BOOKMARKS_FILE" | awk '{for (i = 2; i <= NF; i++) printf "[%s] ", $i; printf $1 "\n"}' | sort -bf | dmenu $DMENU_OPTIONS $DMENU_COLORS -p "Load bookmark:" | awk '{print $NF}') - - [ -n "$URI" ] && zmqat -req "ipc://$SOCKET" "loadUri $URI" - ;; - - # Load all bookmarks for a given tag - "load-tag" ) - TAG=$(awk '{for (i = 2; i <= NF; i++) print $i; }' "$BOOKMARKS_FILE" | sort -bfu | dmenu $DMENU_OPTIONS $DMENU_COLORS -p "Load bookmarks with tag:") - URIs=$(awk '/'$TAG'/ {print $1}' "$BOOKMARKS_FILE" | sort -bfu) - - [ -n "$TAG" ] && [ -n "$URIs" ] || exit 2 - - for URI in $URIs; do - nohup $BROWSER -u "$URI" & - done - ;; - - * ) - echo "Bookmarks manager: bad action" - echo "Usage: bookmarks.sh [COMMAND]" - echo "" - echo "where commands are:" - echo " add - Add a new single bookmark." - echo " add-all - Add all currently opened pages as bookmarks." - echo " delete-tag - Delete all bookmarks with a given tag." - echo " load - Load a single bookmark in current $BROWSER instance." - echo " load-tag - Load all bookmarks with a given tag in new $BROWSER instances." - ;; -esac diff --git a/hbro.cabal b/hbro.cabal --- a/hbro.cabal +++ b/hbro.cabal @@ -1,5 +1,5 @@ Name: hbro -Version: 0.6.2 +Version: 0.6.3 Synopsis: A suckless minimal KISSy browser -- Description: Homepage: http://projects.haskell.org/hbro/ @@ -15,9 +15,7 @@ Cabal-version: >=1.8 Build-type: Simple Extra-source-files: examples/hbro.hs -Data-files: - examples/ui.xml, - examples/scripts/bookmarks.sh +Data-files: examples/ui.xml Source-repository head Type: git @@ -35,7 +33,6 @@ mtl, pango, process, - split, url, webkit, unix, @@ -43,7 +40,11 @@ Exposed-modules: Hbro.Config, Hbro.Core, - Hbro.Extra, + Hbro.Extra.Bookmarks, + Hbro.Extra.Clipboard, + Hbro.Extra.Misc, + Hbro.Extra.Prompt, + Hbro.Extra.StatusBar, Hbro.Gui, Hbro.Socket, Hbro.Types,