hbro 0.6.7 → 0.6.8
raw patch · 15 files changed
+347/−181 lines, 15 filesdep +directory
Dependencies added: directory
Files
- Hbro/Config.hs +0/−3
- Hbro/Core.hs +91/−63
- Hbro/Extra/Bookmarks.hs +14/−14
- Hbro/Extra/BookmarksQueue.hs +7/−7
- Hbro/Extra/Clipboard.hs +13/−0
- Hbro/Extra/History.hs +2/−2
- Hbro/Extra/Prompt.hs +2/−2
- Hbro/Extra/Session.hs +76/−0
- Hbro/Extra/StatusBar.hs +32/−28
- Hbro/Gui.hs +13/−10
- Hbro/Socket.hs +22/−16
- Hbro/Util.hs +17/−3
- examples/hbro.hs +43/−30
- examples/ui.xml +11/−1
- hbro.cabal +4/−2
Hbro/Config.hs view
@@ -10,7 +10,6 @@ -- }}} --- {{{ Dyre showError :: Configuration -> String -> Configuration showError configuration message = configuration { mError = Just message } @@ -21,8 +20,6 @@ Dyre.realMain = realMain, Dyre.ghcOpts = ["-threaded"] }--- }}}- -- | Default configuration. -- Does quite nothing.
Hbro/Core.hs view
@@ -19,13 +19,15 @@ 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.WebDataSource import Graphics.UI.Gtk.WebKit.WebFrame+import Graphics.UI.Gtk.WebKit.WebView import Network.URL import System.Console.CmdArgs import System.Glib.Signals+import System.Process import System.Posix.Process import qualified System.ZMQ as ZMQ -- }}}@@ -49,51 +51,46 @@ -- {{{ Entry point -- | Entry point for the application.--- Parse arguments and step down in favour of initBrowser.--- Print configuration error, if any.+-- Parse commandline arguments, print configuration error if any,+-- create browser and load homepage. realMain :: Configuration -> IO ()-realMain configuration = do+realMain config = do+-- Parse commandline arguments options <- getOptions - case (mError configuration) of- Just e -> putStrLn e- _ -> return ()-- initBrowser configuration options--- }}}- +-- Print configuration error, if any+ maybe (return ()) putStrLn (mError config) --- {{{ Main function--- | Application's main function.--- Create browser and load homepage.-initBrowser :: Configuration -> CliOptions -> IO ()-initBrowser configuration options = do- -- Initialize browser+-- Initialize GUI _ <- initGUI- gui <- loadGUI (mUIFile configuration)- let browser = Browser options configuration gui+ gui <- loadGUI (mUIFile config)+ let browser = Browser options config gui let webView = mWebView gui+ let window = mWindow gui - -- Load additionnal settings from configuration- settings <- mWebSettings configuration- webViewSetWebSettings webView settings- (mSetup configuration) browser+ _ <- onDestroy window mainQuit+ widgetShowAll window+ showPrompt False browser - -- Load homepage- goHome browser+-- Load additionnal settings from configuration+ settings <- mWebSettings config+ webViewSetWebSettings webView settings+ (mSetup config) browser - -- Load key bindings- let keyBindings = importKeyBindings (mKeys configuration)+-- Load key bindings+ let keyBindings = importKeyBindings (mKeys config) - -- On new window request+-- On new window request _ <- on webView createWebView $ \frame -> do newUri <- webFrameGetUri frame- putStrLn "NEW WINDOW" case newUri of- Just uri -> webViewLoadUri webView uri+ Just uri -> do+ whenLoud $ putStrLn ("Requesting new window: " ++ uri ++ "...")+ webViewLoadUri webView uri Nothing -> return () return webView +-- Manage keys _ <- after webView keyPressEvent $ do value <- eventKeyVal modifiers <- eventModifier@@ -104,58 +101,71 @@ Just "<Escape>" -> liftIO $ showPrompt False browser Just string -> do case Map.lookup (Set.fromList modifiers, string) keyBindings of- Just callback -> liftIO $ callback browser- _ -> liftIO $ putStrLn string + Just callback -> do+ liftIO $ callback browser+ liftIO $ whenLoud (putStrLn $ "Key pressed: " ++ show modifiers ++ string ++ " (mapped)")+ _ -> liftIO $ whenLoud (putStrLn $ "Key pressed: " ++ show modifiers ++ string ++ " (unmapped)") _ -> return () return False - -- Connect and show.- _ <- onDestroy (mWindow gui) mainQuit- widgetShowAll (mWindow gui)- showPrompt False browser +-- Load homepage+ case (mURI options) of+ Just uri -> do + webViewLoadUri webView uri+ whenLoud $ putStrLn ("Loading " ++ uri ++ "...")+ _ -> goHome browser - -- Initialize IPC socket+-- Initialize IPC socket pid <- getProcessID- let socketURI = "ipc://" ++ (mSocketDir configuration) ++ "/hbro." ++ show pid- putStrLn $ "Listening socket " ++ socketURI+ let socketURI = "ipc://" ++ (mSocketDir config) ++ "/hbro." ++ show pid + --timeoutAdd (putStrLn "OK" >> return True) 2000+ ZMQ.withContext 1 $ \context -> do _ <- forkIO $ createRepSocket context socketURI browser - mainGUI+ mainGUI -- Main loop + -- Make sure response socket is closed at exit+ whenLoud $ putStrLn "Closing socket..." ZMQ.withSocket context ZMQ.Req $ \reqSocket -> do ZMQ.connect reqSocket socketURI ZMQ.send reqSocket (pack "Quit") []- reply <- ZMQ.receive reqSocket []+ _ <- ZMQ.receive reqSocket [] return ()++ whenNormal $ putStrLn "Exiting..." -- }}} --- {{{ Browse--- | Load homepage (retrieved from commandline options or configuration file)+-- {{{ Browsing functions+-- | Load homepage (set from configuration file). goHome :: Browser -> IO ()-goHome browser = case (mURI $ mOptions browser) of- Just uri -> loadURI uri browser- _ -> loadURI (mHomePage $ mConfiguration browser) browser+goHome browser = do+ whenLoud $ putStrLn ("Loading homepage: " ++ uri)+ loadURI uri browser+ where+ uri = mHomePage $ mConfiguration browser --- | Wrapper around webViewGoBack function+-- | Wrapper around webViewGoBack function, provided for convenience. goBack :: Browser -> IO () goBack browser = webViewGoBack (mWebView $ mGUI browser) --- | Wrapper around webViewGoForward function+-- | Wrapper around webViewGoForward function, provided for convenience. goForward :: Browser -> IO () goForward browser = webViewGoForward (mWebView $ mGUI browser) --- | Wrapper around webViewStopLoading function+-- | Wrapper around webViewStopLoading function, provided for convenience. 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()+-- | Wrapper around webViewReload{BypassCache}.+reload + :: Bool -- ^ If False, cache is bypassed.+ -> Browser+ -> IO () reload True browser = webViewReload (mWebView $ mGUI browser) reload _ browser = webViewReloadBypassCache (mWebView $ mGUI browser) @@ -163,26 +173,28 @@ loadURI :: String -> Browser -> IO () loadURI url browser = case importURL url of- Just url' -> loadURI' url' browser- _ -> return ()+ Just url' -> do+ whenLoud $ putStrLn ("Loading URI: " ++ url)+ loadURI' url' browser+ _ -> return () -- | Backend function for loadURI. loadURI' :: URL -> Browser -> IO () loadURI' url@URL {url_type = Absolute _} browser = webViewLoadUri (mWebView $ mGUI browser) (exportURL url) loadURI' url@URL {url_type = HostRelative} browser = - webViewLoadUri (mWebView $ mGUI browser) ("file://" ++ exportURL url) >> putStrLn (show url)+ webViewLoadUri (mWebView $ mGUI browser) ("file://" ++ exportURL url) loadURI' url@URL {url_type = _} browser = - webViewLoadUri (mWebView $ mGUI browser) ("http://" ++ exportURL url) >> print url+ webViewLoadUri (mWebView $ mGUI browser) ("http://" ++ exportURL url) -- }}} -- {{{ Zoom--- | Wrapper around webViewZoomIn function+-- | Wrapper around webViewZoomIn function, provided for convenience. zoomIn :: Browser -> IO ()-zoomIn browser = webViewZoomIn (mWebView $ mGUI browser)+zoomIn browser = webViewZoomIn (mWebView $ mGUI browser) --- | Wrapper around webViewZoomOut function+-- | Wrapper around webViewZoomOut function, provided for convenience. zoomOut :: Browser -> IO () zoomOut browser = webViewZoomOut (mWebView $ mGUI browser) -- }}}@@ -213,7 +225,7 @@ adjustmentSetValue adjustment upper --- |+-- | Scroll to the left edge of web page. Provided for convenience. horizontalHome :: Browser -> IO () horizontalHome browser = do adjustment <- scrolledWindowGetHAdjustment (mScrollWindow $ mGUI browser)@@ -221,7 +233,7 @@ adjustmentSetValue adjustment lower --- |+-- | Scroll to the right edge of web page. Provided for convenience. horizontalEnd :: Browser -> IO () horizontalEnd browser = do adjustment <- scrolledWindowGetHAdjustment (mScrollWindow $ mGUI browser)@@ -232,13 +244,29 @@ -- | Spawn a new instance of the browser.-newWindow :: Browser -> IO ()-newWindow browser = runExternalCommand "hbro"+newInstance :: IO ()+newInstance = spawn (proc "hbro" []) -- | Execute a javascript file on current webpage. executeJSFile :: String -> Browser -> IO () executeJSFile filePath browser = do+ whenNormal $ putStrLn ("Executing Javascript file: " ++ filePath) script <- readFile filePath let script' = unwords . map (\line -> line ++ "\n") . lines $ script webViewExecuteScript (mWebView $ mGUI browser) script'+++-- | Save current web page to a file,+-- along with all its resources in a separated directory.+-- Doesn't work for now, because web_resource_get_data's binding is missing...+savePage :: String -> Browser -> IO ()+savePage _path browser = do+ frame <- webViewGetMainFrame webView+ dataSource <- webFrameGetDataSource frame+ _mainResource <- webDataSourceGetMainResource dataSource+ _subResources <- webDataSourceGetSubresources dataSource+ return ()+ + where+ webView = mWebView $ mGUI browser
Hbro/Extra/Bookmarks.hs view
@@ -65,9 +65,9 @@ connect reqSocket socketURI send reqSocket (B.pack "getUri") []- uri <- receive reqSocket []+ uri' <- receive reqSocket [] - add (B.unpack uri) (words tags)+ add (B.unpack uri') (words tags) ) _ <- mapM bookmarkPID pidsList@@ -89,7 +89,7 @@ std_out = CreatePipe } _ <- T.hPutStr input file' - entry <- catch (hGetLine output) (\e -> return "ERROR" )+ entry <- catch (hGetLine output) (\_error -> return "ERROR" ) case reverse . words $ entry of ["ERROR"] -> return () uri:_ -> loadURI uri browser@@ -104,8 +104,8 @@ tags' = sort $ map (\tag -> T.snoc (T.cons '[' tag) ']') tags -- | -loadWithTag :: Browser -> IO () -loadWithTag browser = do+loadWithTag :: IO () +loadWithTag = do -- Read bookmarks file configHome <- getEnv "XDG_CONFIG_HOME" file <- T.readFile $ configHome ++ "/hbro/bookmarks"@@ -119,12 +119,12 @@ std_out = CreatePipe } _ <- T.hPutStr input list - tag <- catch (hGetLine output) (\e -> return "ERROR" )+ tag <- catch (hGetLine output) (\_error -> return "ERROR" ) case tag of "ERROR" -> return () "" -> return () t -> do- _ <- mapM (\uri -> runExternalCommand ("hbro -u \"" ++ (T.unpack uri) ++ "\"")) uris+ _ <- mapM (\uri -> spawn (proc "hbro" ["-u", (T.unpack uri)])) uris return () where file' = filter (tagFilter $ T.pack t) (T.lines file)@@ -132,14 +132,14 @@ -- tagFilter :: T.Text -> T.Text -> Bool-tagFilter tag line = let uri:tags = T.words line in case (intersect [tag] tags) of- [t] -> True- _ -> False+tagFilter tag line = let _uri:tags = T.words line in case (intersect [tag] tags) of+ [_tag] -> True+ _ -> False -- |-deleteWithTag :: Browser -> IO ()-deleteWithTag browser = do+deleteWithTag :: IO ()+deleteWithTag = do configHome <- getEnv "XDG_CONFIG_HOME" file <- T.readFile $ configHome ++ "/hbro/bookmarks" @@ -150,11 +150,11 @@ std_out = CreatePipe } _ <- T.hPutStr input tagsList - tag <- catch (hGetLine output) (\e -> return "ERROR" )+ tag <- catch (hGetLine output) (\_error -> return "ERROR" ) case tag of "ERROR" -> return () "" -> return ()- t -> do+ _ -> do T.writeFile (configHome ++ "/hbro/bookmarks.old") file T.writeFile (configHome ++ "/hbro/bookmarks") file' return ()
Hbro/Extra/BookmarksQueue.hs view
@@ -28,7 +28,7 @@ push browser = do uri <- webViewGetUri (mWebView $ mGUI browser) configHome <- getEnv "XDG_CONFIG_HOME"- file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\e -> return T.empty)+ file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\_error -> return T.empty) case uri of Just u ->@@ -44,10 +44,10 @@ _ -> return () -- | Return the first URI from the queue, while removing it.-popFront :: Browser -> IO String-popFront browser = do+popFront :: IO String+popFront = do configHome <- getEnv "XDG_CONFIG_HOME"- file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\e -> return T.empty)+ file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\_error -> return T.empty) if file == T.empty then return ""@@ -61,10 +61,10 @@ return $ T.unpack (head fileLines) -- | Return the last URI from the queue, while removing it.-popBack :: Browser -> IO String-popBack browser = do+popBack :: IO String+popBack = do configHome <- getEnv "XDG_CONFIG_HOME"- file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\e -> return T.empty)+ file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\_error -> return T.empty) if file == T.empty then return ""
Hbro/Extra/Clipboard.hs view
@@ -3,10 +3,13 @@ -- {{{ Imports import Hbro.Core import Hbro.Types+import Hbro.Util import Graphics.UI.Gtk.Abstract.Widget import Graphics.UI.Gtk.General.Clipboard import Graphics.UI.Gtk.WebKit.WebView++import System.Process -- }}} @@ -38,4 +41,14 @@ _ <- clipboardRequestText primaryClip $ \x -> case x of Just uri -> putStrLn ("Loading URI from clipboard: " ++ uri) >> loadURI uri browser _ -> putStrLn "Loading URI from clipboard: empty clipboard."+ return ()++-- | Load URI from clipboard in a new instance of the browser.+newInstanceFromClipboard :: Browser -> IO ()+newInstanceFromClipboard browser = do+ primaryClip <- widgetGetClipboard (mWindow $ mGUI browser) selectionPrimary++ _ <- clipboardRequestText primaryClip $ \x -> case x of+ Just uri -> putStrLn ("Loading URI from clipboard in new instance: " ++ uri) >> spawn (proc "hbro" ["-u", uri])+ _ -> putStrLn "Loading URI from clipboard in new instance: empty clipboard." return ()
Hbro/Extra/History.hs view
@@ -28,7 +28,7 @@ configHome <- getEnv "XDG_CONFIG_HOME" file <- readFile $ configHome ++ "/hbro/history" - let file' = unlines . sort . nub $ map reformat (lines file)+ let file' = unlines . nub $ map reformat (sort . lines $ file) (code, result, e) <- readProcessWithExitCode "dmenu" ["-l", "10"] file' return ()@@ -43,7 +43,7 @@ where reformat line = let- date:time:uri:title = words line + _date:_time:uri:title = words line in unwords $ [uri] ++ title
Hbro/Extra/Prompt.hs view
@@ -15,14 +15,14 @@ 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+ _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 + _found <- webViewSearchText (mWebView $ mGUI browser) keyWord caseSensitive forward wrap return () -- | Prompt for URI to open in current window.
+ Hbro/Extra/Session.hs view
@@ -0,0 +1,76 @@+module Hbro.Extra.Session where++-- {{{ Imports+import Hbro.Types+import Hbro.Util++import qualified Data.Text as T+import qualified Data.Text.IO as T++import Graphics.UI.Gtk.General.General+import Graphics.UI.Gtk.WebKit.WebView++import System.Directory+import System.Environment+import System.Glib.Signals+import System.IO+import System.Posix.Process+import System.Process +-- }}}++setupSession :: Browser -> IO ()+setupSession browser = do+ pid <- getProcessID+ configHome <- getEnv "XDG_CONFIG_HOME"+ previousSession <- getDirectoryContents (configHome ++ "/hbro/") >>= return . (filter sessionFilesFilter)++ let sessionFile = configHome ++ "/hbro/session." ++ show pid++ _ <- on webView loadFinished $ \_ -> do + uri <- webViewGetUri webView+ case uri of+ Just u -> writeFile sessionFile u+ _ -> return ()++ _ <- quitAdd 0 $ do+ removeFile sessionFile+ return False+ + return ()++ where+ webView = mWebView $ mGUI browser++sessionFilesFilter :: String -> Bool+sessionFilesFilter ('s':'e':'s':'s':'i':'o':'n':'.':_) = True+sessionFilesFilter _ = False+++loadFromSession :: Browser -> IO ()+loadFromSession browser = do+ configHome <- getEnv "XDG_CONFIG_HOME"+ previousSession <- getDirectoryContents (configHome ++ "/hbro/") >>= return . (filter sessionFilesFilter)+ sessionURIs <- mapM getSessionURI previousSession +++ (Just input, Just output, _, _) <- createProcess (proc "dmenu" ["-l", "10"]) {+ std_in = CreatePipe,+ std_out = CreatePipe }+ _ <- T.hPutStr input (T.unlines sessionURIs)+ + uri <- catch (hGetLine output) (\_error -> return "ERROR" )+ + case uri of+ "ERROR" -> return ()+ "" -> return ()+ u -> do+ _ <- spawn (proc "hbro" ["-u", u])+ return ()+ +getSessionURI :: String -> IO T.Text+getSessionURI fileName = do+ configHome <- getEnv "XDG_CONFIG_HOME"+ file <- T.readFile $ configHome ++ "/hbro/" ++ fileName++ return $ (head . T.lines) file+
Hbro/Extra/StatusBar.hs view
@@ -17,26 +17,20 @@ 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.+-- Needs a Label entitled "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"+statusBarScrollPosition browser = do+ scrollLabel <- builderGetObject builder castToLabel "scroll"+ adjustment <- scrolledWindowGetVAdjustment scrollWindow - adjustment <- scrolledWindowGetVAdjustment scrollWindow _ <- onValueChanged adjustment $ do- current <- adjustmentGetValue adjustment- lower <- adjustmentGetLower adjustment- upper <- adjustmentGetUpper adjustment+ current <- adjustmentGetValue adjustment+ lower <- adjustmentGetLower adjustment+ upper <- adjustmentGetUpper adjustment page <- adjustmentGetPageSize adjustment case upper-lower-page of@@ -44,9 +38,12 @@ x -> labelSetMarkup scrollLabel $ show (round $ current/x*100) ++ "%" labelSetMarkup scrollLabel "0%"- --return () + where+ builder = mBuilder (mGUI browser)+ scrollWindow = mScrollWindow (mGUI browser) + -- | Display pressed keys in status bar. -- Needs a Label intitled "keys" from the builder. statusBarPressedKeys :: Browser -> IO ()@@ -97,25 +94,32 @@ -- | Display current URI, or the destination of a hovered link, in the status bar.--- Needs a Label intitled "uri" from the builder.+-- Needs a Label named "uri" from the builder. statusBarURI :: Browser -> IO ()-statusBarURI browser = - let- builder = mBuilder (mGUI browser)- webView = mWebView (mGUI browser)- in do+statusBarURI browser = 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>"+ let (color, uri) = case getUri of + Just (u@('h':'t':'t':'p':'s':_)) -> ("orange", u)+ Just u -> ("gray", u) + _ -> ("red", "ERROR")+ + labelSetMarkup uriLabel $ "<span weight=\"bold\" foreground=\"" ++ color ++ "\">" ++ escapeMarkup uri ++ "</span>" - _ <- on webView hoveringOverLink $ \title hoveredUri -> do+ _ <- 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"+ let (color, uri) = case (hoveredUri, getUri) of+ (Just u, _) -> ("#5555ff", u)+ (_, Just (u@('h':'t':'t':'p':'s':_))) -> ("orange", u)+ (_, Just u) -> ("white", u)+ _ -> ("red", "ERROR")+ + labelSetMarkup uriLabel $ "<span weight=\"bold\" foreground=\"" ++ color ++ "\">" ++ escapeMarkup uri ++ "</span>" return ()++ where+ builder = mBuilder (mGUI browser)+ webView = mWebView (mGUI browser)+
Hbro/Gui.hs view
@@ -6,7 +6,6 @@ import Control.Monad.Trans(liftIO) ---import Graphics.UI.Gtk.Abstract.Misc import Graphics.UI.Gtk.Abstract.Container import Graphics.UI.Gtk.Abstract.Widget import Graphics.UI.Gtk.Builder@@ -21,6 +20,7 @@ import Graphics.UI.Gtk.WebKit.WebView import Graphics.UI.Gtk.Windows.Window +import System.Console.CmdArgs (whenNormal, whenLoud) import System.Glib.Attributes import System.Glib.Signals -- }}}@@ -29,20 +29,22 @@ -- | Load GUI from XML file loadGUI :: String -> IO GUI loadGUI xmlPath = do+ whenNormal $ putStrLn ("Loading GUI from " ++ xmlPath ++ "...")++-- builder <- builderNew builderAddFromFile builder xmlPath - -- Init main web view+-- Init main web view webView <- webViewNew set webView [ widgetCanDefault := True ] _ <- on webView closeWebView $ do mainQuit- return True+ return False - -- Load main window+-- Load main window window <- builderGetObject builder castToWindow "mainWindow" windowSetDefault window (Just webView)- set window [ windowTitle := "hbro" ] scrollWindow <- builderGetObject builder castToScrolledWindow "webViewParent" containerAdd scrollWindow webView @@ -54,10 +56,11 @@ promptEntry <- builderGetObject builder castToEntry "promptEntry" statusBox <- builderGetObject builder castToHBox "statusBox" - -- Create web inspector's window+-- Create web inspector's window inspector <- webViewGetInspector webView inspectorWindow <- initWebInspector inspector-+ + whenLoud $ putStrLn "Done." return $ GUI window inspectorWindow scrollWindow webView promptLabel promptEntry statusBox builder @@ -131,16 +134,16 @@ promptEntry = (mPromptEntry $ mGUI browser) webView = (mWebView $ mGUI browser) in do- -- Fill prompt+ -- Fill prompt labelSetText promptLabel label entrySetText promptEntry defaultText - -- Focus on prompt+ -- Focus on prompt showPrompt True browser widgetGrabFocus promptEntry editableSetPosition promptEntry (-1) - -- Register callback+ -- Register callback case incremental of True -> do id1 <- on promptEntry editableChanged $
Hbro/Socket.hs view
@@ -9,13 +9,15 @@ import Graphics.UI.Gtk.General.General import Graphics.UI.Gtk.WebKit.WebView +import System.Console.CmdArgs (whenNormal, whenLoud) import System.ZMQ -- }}} -- | Create a response socket to listen for commands. -- Loops on listenToSocket until "Quit" command is received. createRepSocket :: Context -> String -> Browser -> IO ()-createRepSocket context socketURI browser =+createRepSocket context socketURI browser = do+ whenNormal $ putStrLn ("Listening socket at " ++ socketURI) withSocket context Rep $ \repSocket -> do bind repSocket socketURI listenToSocket repSocket commandsList browser@@ -27,11 +29,17 @@ -- Parse received commands and feed the corresponding callback, if any. listenToSocket :: Socket Rep -> CommandsMap -> Browser -> IO () listenToSocket repSocket commands browser = do- message <- receive repSocket []- case words (unpack message) of- [] -> send repSocket (pack "ERROR Unknown command") []+ message <- receive repSocket []+ let message' = unpack message++ case words message' of+ -- Empty command+ [] -> send repSocket (pack "ERROR Unknown command") []+ -- Exit command ["Quit"] -> send repSocket (pack "OK") []+ -- Valid command command:arguments -> do+ whenLoud $ putStrLn ("Receiving command: " ++ message') case Map.lookup command commands of Just callback -> callback arguments repSocket browser _ -> send repSocket (pack "ERROR Unknown command") []@@ -42,25 +50,25 @@ defaultCommandsList :: CommandsList defaultCommandsList = [ -- Get information- ("getUri", \arguments repSocket browser -> do+ ("getUri", \_arguments repSocket browser -> do getUri <- postGUISync $ webViewGetUri (mWebView $ mGUI browser) case getUri of Just uri -> send repSocket (pack uri) [] _ -> send repSocket (pack "ERROR No URL opened") [] ), - ("getTitle", \arguments repSocket browser -> do+ ("getTitle", \_arguments repSocket browser -> do getTitle <- postGUISync $ webViewGetTitle (mWebView $ mGUI browser) case getTitle of Just title -> send repSocket (pack title) [] _ -> send repSocket (pack "ERROR No title") [] ), - ("getFaviconUri", \arguments repSocket browser -> do+ ("getFaviconUri", \_arguments repSocket browser -> do getUri <- postGUISync $ webViewGetIconUri (mWebView $ mGUI browser) case getUri of Just uri -> send repSocket (pack uri) [] _ -> send repSocket (pack "ERROR No favicon uri") [] ), - ("getLoadProgress", \arguments repSocket browser -> do+ ("getLoadProgress", \_arguments repSocket browser -> do progress <- postGUISync $ webViewGetProgress (mWebView $ mGUI browser) send repSocket (pack (show progress)) [] ), @@ -72,30 +80,28 @@ send repSocket (pack "OK") [] _ -> send repSocket (pack "ERROR: argument needed.") [] ), - ("stopLoading", \arguments repSocket browser -> do+ ("stopLoading", \_arguments repSocket browser -> do postGUIAsync $ webViewStopLoading (mWebView $ mGUI browser) send repSocket (pack "OK") [] ), - ("reload", \arguments repSocket browser -> do+ ("reload", \_arguments repSocket browser -> do postGUIAsync $ webViewReload (mWebView $ mGUI browser) send repSocket (pack "OK") [] ), - ("goBack", \arguments repSocket browser -> do+ ("goBack", \_arguments repSocket browser -> do postGUIAsync $ webViewGoBack (mWebView $ mGUI browser) send repSocket (pack "OK") [] ), - ("goForward", \arguments repSocket browser -> do+ ("goForward", \_arguments repSocket browser -> do postGUIAsync $ webViewGoForward (mWebView $ mGUI browser) send repSocket (pack "OK") [] ), - ("zoomIn", \arguments repSocket browser -> do+ ("zoomIn", \_arguments repSocket browser -> do postGUIAsync $ webViewZoomIn (mWebView $ mGUI browser) send repSocket (pack "OK") [] ), - ("zoomOut", \arguments repSocket browser -> do+ ("zoomOut", \_arguments repSocket browser -> do postGUIAsync $ webViewZoomOut (mWebView $ mGUI browser) send repSocket (pack "OK") [] ) ]--
Hbro/Util.hs view
@@ -6,7 +6,12 @@ import qualified Data.Map as Map import qualified Data.Set as Set -import Graphics.UI.Gtk+import Graphics.UI.Gtk.Display.Label+import Graphics.UI.Gtk.Gdk.EventM+import Graphics.UI.Gtk.Gdk.Keys+import Graphics.UI.Gtk.General.General++--import System.Console.CmdArgs (whenLoud, whenNormal) import System.Process -- }}} @@ -62,6 +67,15 @@ -- | Run external command and won't kill when parent process exit. -- nohup for ignore all hup signal. -- `> /dev/null 2>&1` redirect all stdout (1) and stderr (2) to `/dev/null`-runExternalCommand :: String -> IO ()-runExternalCommand command = runCommand' $ "nohup " ++ command ++ " > /dev/null 2>&1"+spawn :: CreateProcess -> IO ()+--spawn command = runCommand' $ "nohup " ++ command ++ " > /dev/null 2>&1"+spawn command = createProcess command { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe, close_fds = True } >> return () -- }}}++-- | Set a temporary markup text to a label that disappears after some delay.+labelSetMarkupTemporary :: Label -> String -> Int -> IO HandlerId+labelSetMarkupTemporary label text delay = do+ labelSetMarkup label text+ timeoutAdd clear delay+ where+ clear = labelSetMarkup label "" >> return False
examples/hbro.hs view
@@ -9,12 +9,15 @@ import Hbro.Extra.History import Hbro.Extra.Misc import Hbro.Extra.Prompt+import Hbro.Extra.Session import Hbro.Extra.StatusBar import Hbro.Gui import Hbro.Types import Hbro.Util 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@@ -54,14 +57,14 @@ -- {{{ Keys -- Note that this example is suited for an azerty keyboard. myKeys :: KeysList-myKeys = generalKeys ++ bookmarksKeys ++ historyKeys+myKeys = generalKeys ++ bookmarksKeys ++ historyKeys ++ sessionKeys generalKeys :: KeysList generalKeys = [ -- ((modifiers, key), callback)- -- Browse+-- Browse (([Control], "<Left>"), goBack),- (([Shift], "<Right>"), goForward),+ (([Control], "<Right>"), goForward), (([Control], "s"), stopLoading), (([], "<F5>"), reload True), (([Shift], "<F5>"), reload False),@@ -74,7 +77,7 @@ (([Alt], "<Home>"), goHome), (([Control], "g"), promptGoogle), - -- Display+-- Display (([Control, Shift], "+"), zoomIn), (([Control], "-"), zoomOut), (([], "<F11>"), fullscreen),@@ -82,26 +85,27 @@ (([Control], "b"), toggleStatusBar), (([Control], "u"), toggleSourceMode), - -- Prompt+-- Prompt (([Control], "o"), promptURL False), (([Control, Shift], "O"), promptURL True), - -- Search+-- 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), - -- Copy/paste+-- Copy/paste (([Control], "y"), copyUri), (([Control, Shift], "Y"), copyTitle), (([Control], "p"), loadURIFromClipboard),+ (([Control, Shift], "P"), newInstanceFromClipboard), - -- Others+-- Others (([Control], "i"), showWebInspector), (([Alt], "p"), printPage),- (([Control], "t"), newWindow),+ (([Control], "t"), \_ -> newInstance), (([Control], "w"), \_ -> mainQuit) ] @@ -109,12 +113,12 @@ bookmarksKeys = [ (([Control], "d"), Bookmarks.addWithTags), (([Control, Shift], "D"), Bookmarks.addAllWithTags),- (([Alt], "d"), Bookmarks.deleteWithTag),+ (([Alt], "d"), \_ -> Bookmarks.deleteWithTag), (([Control], "l"), Bookmarks.load),- (([Control, Shift], "L"), Bookmarks.loadWithTag),+ (([Control, Shift], "L"), \_ -> Bookmarks.loadWithTag), (([Control], "q"), Queue.append), (([Alt], "q"), \b -> do- uri <- Queue.popFront b+ uri <- Queue.popFront loadURI uri b) ] @@ -122,8 +126,12 @@ historyKeys = [ (([Control], "h"), loadFromHistory) ]--- }}} +sessionKeys :: KeysList+sessionKeys = [+ (([Alt], "l"), loadFromSession)+ ]+-- }}} -- {{{ Web settings -- Commented lines correspond to default values@@ -175,7 +183,6 @@ return settings -- }}} - -- {{{ Setup mySetup :: Browser -> IO () mySetup browser = @@ -185,31 +192,37 @@ scrollWindow = mScrollWindow (mGUI browser) window = mWindow (mGUI browser) in do- -- Default background (for status bar)+ -- Default background (basically for status bar) widgetModifyBg window StateNormal (Color 0 0 10000) - -- Status bar+ -- Status bar statusBarScrollPosition browser statusBarPressedKeys browser statusBarLoadProgress browser statusBarURI browser + -- Session manager+ setupSession browser+ _ <- on webView titleChanged $ \_ title -> set window [ windowTitle := ("hbro | " ++ title)] - -- Download requests+ -- Download requests _ <- on webView downloadRequested $ \download -> do uri <- downloadGetUri download name <- downloadGetSuggestedFilename download size <- downloadGetTotalSize download+ feedbackLabel <- builderGetObject builder castToLabel "feedback" case (uri, name) of- (Just uri', Just name') -> myDownload uri' name' - _ -> return ()+ (Just uri', Just name') -> do+ myDownload uri' name' + labelSetMarkupTemporary feedbackLabel "<span foreground=\"green\">Download started</span>" 5000+ _ -> labelSetMarkupTemporary feedbackLabel "<span foreground=\"red\">Unable to download</span>" 5000 return False - -- Per MIME actions+ -- Per MIME actions _ <- on webView mimeTypePolicyDecisionRequested $ \_ request mimetype policyDecision -> do show <- webViewCanShowMimeType webView mimetype @@ -218,7 +231,7 @@ _ -> webPolicyDecisionDownload policyDecision >> return True - -- History handler+ -- History handler _ <- on webView loadFinished $ \_ -> do uri <- webViewGetUri webView title <- webViewGetTitle webView@@ -227,8 +240,8 @@ _ -> return () - -- On navigating to a new URI- -- Return True to forbid navigation, False to allow+ -- 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@@ -241,22 +254,22 @@ Just uri -> case mouseButton of 1 -> return False -- Left button - 2 -> runExternalCommand ("hbro -u \"" ++ uri ++ "\"") >> return True -- Middle button+ 2 -> spawn (proc "hbro" ["-u", uri]) >> putStrLn uri >> return True -- Middle button 3 -> return False -- Right button _ -> return False -- No mouse button pressed _ -> return False - -- On requesting new window+ -- On requesting new window _ <- on webView newWindowPolicyDecisionRequested $ \_ request action policyDecision -> do getUri <- networkRequestGetUri request case getUri of- Just uri -> runExternalCommand $ "hbro -u \"" ++ uri ++ "\""+ Just uri -> (spawn $ proc "hbro" ["-u", uri]) >> putStrLn uri _ -> putStrLn "ERROR: wrong URI given, unable to open window." return True - -- Favicon+ -- Favicon --_ <- on webView iconLoaded $ \uri -> do something return ()@@ -266,9 +279,9 @@ myDownload :: String -> String -> IO () myDownload uri name = do home <- getEnv "HOME"- --runExternalCommand $ "wget \"" ++ uri ++ "\" -O \"" ++ home ++ "/" ++ name ++ "\""- --runExternalCommand $ "axel \"" ++ uri ++ "\" -o \"" ++ home ++ "/" ++ name ++ "\""- runExternalCommand $ "aria2c \"" ++ uri ++ "\" -d " ++ home ++ "/ -o \"" ++ name ++ "\""+ --spawn $ proc "wget [uri, "-O", home ++ "/" ++ name]+ --spawn $ proc "axel [uri, "-o", home ++ "/" ++ name]+ spawn $ proc "aria2c" [uri, "-d", home ++ "/", "-o", name] promptGoogle :: Browser -> IO () promptGoogle browser =
examples/ui.xml view
@@ -55,7 +55,7 @@ <property name="yalign">0</property> </object> </child>- + <child> <object class="GtkLabel" id="scroll"></object> <packing>@@ -73,6 +73,16 @@ <property name="expand">False</property> </packing> </child>++ <child>+ <object class="GtkLabel" id="feedback"></object>+ <packing>+ <property name="pack-type">GTK_PACK_END</property>+ <property name="fill">False</property>+ <property name="expand">False</property>+ </packing>+ </child>+ </object> <packing>
hbro.cabal view
@@ -1,6 +1,6 @@ Name: hbro-Version: 0.6.7-Synopsis: A suckless minimal KISSy browser+Version: 0.6.8+Synopsis: A minimal KISS compliant browser -- Description: Homepage: http://projects.haskell.org/hbro/ Category: Browser,Web@@ -27,6 +27,7 @@ bytestring, cmdargs, containers,+ directory, dyre, glib, gtk,@@ -49,6 +50,7 @@ Hbro.Extra.History, Hbro.Extra.Misc, Hbro.Extra.Prompt,+ Hbro.Extra.Session, Hbro.Extra.StatusBar, Hbro.Gui, Hbro.Socket,