packages feed

hbro 0.6.2 → 0.6.3

raw patch · 15 files changed

+480/−382 lines, 15 filesdep −split

Dependencies removed: split

Files

Hbro/Config.hs view
@@ -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.
Hbro/Core.hs view
@@ -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 "<Escape>" -> 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"
− Hbro/Extra.hs 
@@ -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 $ "<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)-    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--- }}}
+ Hbro/Extra/Bookmarks.hs view
@@ -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+-- }}}
+ Hbro/Extra/Clipboard.hs view
@@ -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 ()
+ Hbro/Extra/Misc.hs view
@@ -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
+ Hbro/Extra/Prompt.hs view
@@ -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 ()
+ Hbro/Extra/StatusBar.hs view
@@ -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 $ "<span foreground=\"green\">" ++ escapeMarkup k ++ "</span>"+            (Just k, m)     -> liftIO $ labelSetMarkup keysLabel $ "<span foreground=\"green\">" ++ show m ++ escapeMarkup k ++ "</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 ()
Hbro/Gui.hs view
@@ -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
Hbro/Main.hs view
@@ -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
Hbro/Socket.hs view
@@ -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
Hbro/Types.hs view
@@ -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
examples/hbro.hs view
@@ -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],        "<Home>"),      verticalHome),     (([Control],        "<End>"),       verticalEnd),     (([Alt],            "<Home>"),      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"--- }}}
− examples/scripts/bookmarks.sh 
@@ -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
hbro.cabal view
@@ -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,