hbro 0.7.1.1 → 0.8.0.0
raw patch · 18 files changed
+335/−1224 lines, 18 filesdep +filepathdep +networkdep −old-localedep −textdep −time
Dependencies added: filepath, network
Dependencies removed: old-locale, text, time, url
Files
- Hbro/Core.hs +14/−191
- Hbro/Extra/Bookmarks.hs +0/−98
- Hbro/Extra/BookmarksQueue.hs +0/−81
- Hbro/Extra/Clipboard.hs +0/−21
- Hbro/Extra/History.hs +0/−53
- Hbro/Extra/Misc.hs +0/−95
- Hbro/Extra/Session.hs +0/−60
- Hbro/Extra/StatusBar.hs +0/−170
- Hbro/Gui.hs +32/−20
- Hbro/Hbro.hs +191/−0
- Hbro/Main.hs +1/−1
- Hbro/Socket.hs +19/−15
- Hbro/Types.hs +15/−12
- Hbro/Util.hs +55/−26
- README.rst +2/−1
- examples/hbro.hs +0/−320
- examples/ui.xml +1/−47
- hbro.cabal +5/−13
Hbro/Core.hs view
@@ -1,12 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DoRec #-} module Hbro.Core (--- * Main- defaultConfig,- launchHbro, -- * Browsing goHome,- loadURI, -- * Scrolling goTop, goBottom,@@ -18,221 +14,50 @@ ) where -- {{{ Imports-import Hbro.Gui-import Hbro.Keys-import Hbro.Socket import Hbro.Types---import Hbro.Util--import qualified Config.Dyre as D-import Config.Dyre.Paths--import Control.Concurrent-import Control.Monad.Reader+import Hbro.Util -import qualified Data.Map as M+import Data.Foldable -import Graphics.UI.Gtk.Abstract.Widget-import Graphics.UI.Gtk.General.General hiding(initGUI) import Graphics.UI.Gtk.Misc.Adjustment import Graphics.UI.Gtk.Scrolling.ScrolledWindow import Graphics.UI.Gtk.WebKit.WebDataSource import Graphics.UI.Gtk.WebKit.WebFrame-import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.WebKit.WebView hiding(webViewGetUri, webViewLoadUri) -import Network.URL+import Network.URI import System.Console.CmdArgs-import System.Directory-import System.Environment.XDG.BaseDir-import System.Glib.Signals-import System.IO-import System.Posix.Process-import System.Posix.Signals-import qualified System.ZMQ as ZMQ -- }}} --- {{{ Commandline options-cliOptions :: CliOptions-cliOptions = CliOptions {- mURI = def &= help "URI to open at start-up" &= explicit &= name "u" &= name "uri" &= typ "URI",- mVanilla = def &= help "Do not read custom configuration file." &= explicit &= name "1" &= name "vanilla",- mDenyReconf = def &= help "Deny recompilation even if the configuration file has changed." &= explicit &= name "deny-reconf",- mForceReconf = def &= help "Force recompilation even if the configuration file hasn't changed." &= explicit &= name "force-reconf",- mDyreDebug = def &= help "Force the application to use './cache/' as the cache directory, and ./ as the configuration directory. Useful to debug the program without installation." &= explicit &= name "dyre-debug",- mMasterBinary = def &= explicit &= name "dyre-master-binary"-}--getOptions :: IO CliOptions-getOptions = cmdArgs $ cliOptions- &= verbosityArgs [explicit, name "verbose", name "v"] []- &= versionArg [ignore]- &= help "A minimal KISS-compliant browser."- &= helpArg [explicit, name "help", name "h"]- &= program "hbro"--- }}}---- {{{ Configuration (Dyre)-dyreParameters :: D.Params (Config, CliOptions)-dyreParameters = D.defaultParams {- D.projectName = "hbro",- D.showError = showError,- D.realMain = realMain,- D.ghcOpts = ["-threaded"],- D.statusOut = hPutStrLn stderr-}--showError :: (Config, a) -> String -> (Config, a)-showError (config, x) message = (config { mError = Just message }, x)---- | Default configuration.--- Homepage: Google, socket directory: /tmp,--- UI file: ~/.config/hbro/, no key/command binding.-defaultConfig :: CommonDirectories -> Config-defaultConfig directories = Config {- mCommonDirectories = directories,- mHomePage = "https://encrypted.google.com/",- mSocketDir = mTemporary directories,- mUIFile = (mConfiguration directories) ++ "/ui.xml",- mKeyEventHandler = simpleKeyEventHandler,- mKeyEventCallback = \_ -> simpleKeyEventCallback (keysListToMap []),- mWebSettings = [],- mSetup = const (return () :: IO ()),- mCommands = [],- mError = Nothing-}--- }}}---- {{{ Entry point--- | Browser's main function.--- To be called in main function with a proper configuration.--- See Hbro.Main for an example.-launchHbro :: (CommonDirectories -> Config) -> IO ()-launchHbro configGenerator = do- homeDir <- getHomeDirectory- tmpDir <- getTemporaryDirectory- configDir <- getUserConfigDir "hbro"- dataDir <- getUserDataDir "hbro"- options <- getOptions- - let config = configGenerator (CommonDirectories homeDir tmpDir configDir dataDir)- - case mVanilla options of- True -> D.wrapMain dyreParameters{ D.configCheck = False } (config, options)- _ -> D.wrapMain dyreParameters (config, options)--realMain :: (Config, CliOptions) -> IO ()-realMain (config, options) = do--- Print configuration error, if any- maybe (return ()) putStrLn $ mError config---- Print in-use paths- whenLoud $ getPaths dyreParameters >>= \(a,b,c,d,e) -> do - putStrLn ("Current binary: " ++ a)- putStrLn ("Custom binary: " ++ b)- putStrLn ("Config file: " ++ c)- putStrLn ("Cache directory: " ++ d)- putStrLn ("Lib directory: " ++ e)- putStrLn ""- --- Initialize GUI- gui <- initGUI (mUIFile config) (mWebSettings config)---- Initialize IPC socket- ZMQ.withContext 1 $ realMain' config options gui--realMain' :: Config -> CliOptions -> GUI -> ZMQ.Context -> IO ()-realMain' config options gui@GUI {mWebView = webView, mWindow = window} context = let- environment = Environment options config gui context- setup = mSetup config- socketDir = mSocketDir config - commands = mCommands config- keyEventHandler = mKeyEventHandler config- keyEventCallback = (mKeyEventCallback config) environment- in do--- Apply custom setup- setup environment- --- Setup key handler- rec i <- after webView keyPressEvent $ keyEventHandler keyEventCallback i webView---- Load homepage- case (mURI options) of- Just uri -> do - fileURI <- doesFileExist uri- case fileURI of- True -> getCurrentDirectory >>= \dir -> webViewLoadUri webView $ "file://" ++ dir ++ "/" ++ uri- _ -> webViewLoadUri webView uri- - whenLoud $ putStrLn ("Loading " ++ uri ++ "...")- _ -> goHome webView config---- Open socket- pid <- getProcessID- let commandsList = M.fromList $ defaultCommandsList ++ commands- let socketURI = "ipc://" ++ socketDir ++ "/hbro." ++ show pid- void $ forkIO (openRepSocket context socketURI (listenToCommands environment commandsList))- --- Manage POSIX signals- void $ installHandler sigINT (Catch interruptHandler) Nothing-- --timeoutAdd (putStrLn "OK" >> return True) 2000- mainGUI -- Main loop---- Make sure response socket is closed at exit- whenLoud $ putStrLn "Closing socket..."- closeSocket context socketURI- whenNormal $ putStrLn "Exiting..."--interruptHandler :: IO ()-interruptHandler = do- whenLoud $ putStrLn "Received SIGINT."- mainQuit--- }}}---- {{{ Browsing functions+-- {{{ Browsing -- | Load homepage (set from configuration file). goHome :: WebView -> Config -> IO ()-goHome webView config = do- whenLoud $ putStrLn ("Loading homepage: " ++ uri)- loadURI webView uri- where- uri = mHomePage config---- | Wrapper around webViewLoadUri meant to transparently add the proper protocol prefix (http:// or file://).--- Most of the time, you want to use this function instead of webViewLoadUri.-loadURI :: WebView -> String -> IO ()-loadURI webView uri = do- whenLoud $ putStrLn ("Loading URI: " ++ uri)- case importURL uri of- Just uri'@URL {url_type = Absolute _} -> webViewLoadUri webView (exportURL uri')- Just uri'@URL {url_type = HostRelative} -> webViewLoadUri webView ("file://" ++ exportURL uri')- Just uri'@URL {url_type = _} -> webViewLoadUri webView ("http://" ++ exportURL uri')- _ -> whenNormal $ putStrLn ("WARNING: not a valid URI: " ++ uri)+goHome webView config@Config{ mHomePage = homeURI } = forM_ (parseURIReference homeURI) $ webViewLoadUri webView -- }}} -- {{{ Scrolling -- | Scroll up to top of web page. Provided for convenience. goTop :: ScrolledWindow -> IO () goTop window = do- adjustment <- scrolledWindowGetVAdjustment window- lower <- adjustmentGetLower adjustment+ adjustment <- scrolledWindowGetVAdjustment window+ lower <- adjustmentGetLower adjustment adjustmentSetValue adjustment lower -- | Scroll down to bottom of web page. Provided for convenience. goBottom :: ScrolledWindow -> IO () goBottom window = do- adjustment <- scrolledWindowGetVAdjustment window- upper <- adjustmentGetUpper adjustment+ adjustment <- scrolledWindowGetVAdjustment window+ upper <- adjustmentGetUpper adjustment adjustmentSetValue adjustment upper -- | Scroll to the left edge of web page. Provided for convenience. goLeft :: ScrolledWindow -> IO () goLeft window = do- adjustment <- scrolledWindowGetHAdjustment window- lower <- adjustmentGetLower adjustment+ adjustment <- scrolledWindowGetHAdjustment window+ lower <- adjustmentGetLower adjustment adjustmentSetValue adjustment lower @@ -248,13 +73,11 @@ -- {{{ Misc -- | Wrapper around webFramePrint function, provided for convenience. printPage :: WebView -> IO ()-printPage webView = do- frame <- webViewGetMainFrame webView- webFramePrint frame+printPage webView = webViewGetMainFrame webView >>= webFramePrint -- | Execute a javascript file on current webpage.-executeJSFile :: String -> WebView -> IO ()+executeJSFile :: FilePath -> WebView -> IO () executeJSFile filePath webView = do whenNormal $ putStrLn ("Executing Javascript file: " ++ filePath) script <- readFile filePath
− Hbro/Extra/Bookmarks.hs
@@ -1,98 +0,0 @@-module Hbro.Extra.Bookmarks (- select,- selectTag,- deleteWithTag,- add,-) where---- {{{ Imports---import Hbro.Core---import Hbro.Gui---import Hbro.Types-import Hbro.Util----import qualified Data.ByteString.Char8 as B-import Data.List-import qualified Data.Text as T-import qualified Data.Text.IO as T--- }}}------ | The elementary bookmark action-add :: FilePath -> String -> [String] -> IO ()-add bookmarksFile uri tags = appendFile bookmarksFile $ uri ++ " " ++ (unwords tags) ++ "\n"----- |-select :: FilePath -> [String] -> IO (Maybe String)-select bookmarksFile dmenuOptions = do--- Load bookmarks file- file <- T.readFile bookmarksFile- let file' = T.unlines . sort . nub $ map reformat (T.lines file)---- Let user select a URI- selection <- dmenu dmenuOptions file'-- case reverse . words $ selection of- [] -> return Nothing- uri:_ -> return $ Just uri-- -reformat :: T.Text -> T.Text-reformat line = T.unwords $ tags' ++ [uri]- where- uri:tags = T.words line - tags' = sort $ map (\tag -> T.snoc (T.cons '[' tag) ']') tags---- | -selectTag :: FilePath -> [String] -> IO (Maybe [String])-selectTag bookmarksFile dmenuOptions = do- -- Read bookmarks file- file <- T.readFile bookmarksFile-- -- Filter tags list- let list = T.unlines . sort . nub . T.words . T.unwords $ map getTags (T.lines file)-- -- Let user select a tag- selection <- dmenu dmenuOptions list-- case selection of- "" -> return Nothing- tag -> return $ Just uris---mapM (\uri -> spawn "hbro" ["-u", (T.unpack uri)]) uris >> return ()- where- file' = filter (tagFilter $ T.pack tag) (T.lines file)- uris = map (T.unpack . getUri) file'---- -tagFilter :: T.Text -> T.Text -> Bool-tagFilter tag line = let _uri:tags = T.words line in case (intersect [tag] tags) of- [_tag] -> True- _ -> False----- |-deleteWithTag :: FilePath -> [String] -> IO ()-deleteWithTag bookmarksFile dmenuOptions = do- file <- T.readFile bookmarksFile-- let tagsList = T.unlines . sort . nub . T.words . T.unwords $ map getTags (T.lines file)-- selection <- dmenu dmenuOptions tagsList- case selection of- "" -> return ()- _ -> do- T.writeFile (bookmarksFile ++ ".old") file- T.writeFile bookmarksFile file'- return ()- where- file' = T.unlines $ filter (not . (tagFilter $ T.pack selection)) (T.lines file)---- |-getTags :: T.Text -> T.Text-getTags line = let _:tags = T.words line in T.unwords tags---- |-getUri :: T.Text -> T.Text-getUri line = let uri:_ = T.words line in uri
− Hbro/Extra/BookmarksQueue.hs
@@ -1,81 +0,0 @@-module Hbro.Extra.BookmarksQueue where---- {{{ Imports---import Hbro.Types--import Data.List-import qualified Data.Text as T-import qualified Data.Text.IO as T--- }}}----- | Add current URI to the end of the queue.---append :: String -> IO ()---append bookmarksFile uri = do--- configHome <- getEnv "XDG_CONFIG_HOME"--- appendFile (configHome ++ "/hbro/queue") (uri ++ "\n")---- | Add current URI to the beginning of the queue.-push :: String -> String -> IO ()-push bookmarksFile uri = do- file <- catch (T.readFile bookmarksFile) (\_error -> return T.empty)-- if (file == T.empty)- then return ()- else do- let fileLines = T.lines file- let file' = T.unlines . nub $ (T.pack uri):fileLines- - T.writeFile bookmarksFile file'- - return ()---- | Return the first URI from the queue, while removing it.-popFront :: String -> IO String-popFront bookmarksFile = do- file <- catch (T.readFile bookmarksFile) (\_error -> return T.empty)-- if file == T.empty- then return ""- else do- let fileLines = T.lines file- let file' = T.unlines . tail . nub $ fileLines- - T.writeFile (bookmarksFile ++ ".old") file- T.writeFile bookmarksFile file'-- return $ T.unpack (head fileLines)---- | Return the last URI from the queue, while removing it.-popBack :: String -> IO String-popBack bookmarksFile = do- file <- catch (T.readFile bookmarksFile) (\_error -> return T.empty)-- if file == T.empty- then return ""- else do- let fileLines = T.lines file- let file' = T.unlines . reverse . tail . reverse. nub $ fileLines- - T.writeFile (bookmarksFile ++ ".old") file- T.writeFile bookmarksFile file'-- return $ T.unpack (head $ reverse fileLines)---- | Return a random URI from the queue, while removing it.--- popRandom :: Browser -> IO String--- popRandom browser = do--- configHome <- getEnv "XDG_CONFIG_HOME"--- file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\e -> return T.empty)---- if file == T.empty--- then return ""--- else do--- let fileLines = T.lines file--- let file' = T.unlines . reverse . tail . reverse. nub $ fileLines--- --- T.writeFile (configHome ++ "/hbro/queue.old") file--- T.writeFile (configHome ++ "/hbro/queue") file'---- return $ T.unpack (head $ reverse fileLines)-
− Hbro/Extra/Clipboard.hs
@@ -1,21 +0,0 @@-module Hbro.Extra.Clipboard where---- {{{ Imports---import Hbro.Core---import Hbro.Types---import Hbro.Util--import Graphics.UI.Gtk.General.Clipboard--- }}}----- | Copy current URI in clipboard.-toClipboard :: String -> IO ()-toClipboard text = do- primaryClip <- clipboardGet selectionPrimary- clipboardSetText primaryClip text- -withClipboard :: (Maybe String -> IO ()) -> IO ()-withClipboard callback = do- primaryClip <- clipboardGet selectionPrimary- clipboardRequestText primaryClip callback
− Hbro/Extra/History.hs
@@ -1,53 +0,0 @@-module Hbro.Extra.History where---- {{{ Imports---import Hbro.Core---import Hbro.Types-import Hbro.Util----import Control.Monad.Reader--import Data.List-import qualified Data.Text as T-import qualified Data.Text.IO as T-import Data.Time----import System.IO.Error-import System.Locale--- }}} ----- | Add a single history entry to the history file-add :: FilePath -- ^ Path to history file- -> String -- ^ URI for the new history entry- -> String -- ^ Title for the new history entry- -> IO ()-add historyFile uri title = do- now <- getCurrentTime- let time = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" now- let newLine = time ++ " " ++ uri ++ " " ++ title ++ "\n"- _ <- catch (appendFile historyFile newLine) (\_ -> putStrLn $ "[WARNING] You need to create history file" ++ historyFile)- return ()- ---- | Open a dmenu to select a history entry-select :: FilePath -- ^ Path to history file- -> [String] -- ^ Options to pass to dmenu- -> IO (Maybe String) -- ^ Selected history entry-select historyFile dmenuOptions = do- file <- T.readFile historyFile-- let file' = T.unlines . nub $ map reformat (sort . T.lines $ file)-- selection <- dmenu dmenuOptions file'- case selection of- "" -> return Nothing- entry -> return $ Just ((head . words) entry)--reformat :: T.Text -> T.Text-reformat line = - let- _date:_time:uri:title = T.words line - in - T.unwords $ [uri] ++ title-
− Hbro/Extra/Misc.hs
@@ -1,95 +0,0 @@-module Hbro.Extra.Misc where---- {{{ Imports---import Hbro.Core---import Hbro.Types-import Hbro.Util--import Data.Maybe-import qualified Data.Text as T-import qualified Data.Text.IO as T--import Graphics.UI.Gtk.Display.Label-import Graphics.UI.Gtk.WebKit.WebBackForwardList-import Graphics.UI.Gtk.WebKit.WebHistoryItem-import Graphics.UI.Gtk.WebKit.WebView--import System.IO--- }}}----- | Same as goBack function from Hbro.Core,--- but with feedback in case of failure.---goForward :: WebView -> IO ()---goForward webView = do--- result <- webViewCanGoForward webView--- feedbackLabel <- builderGetObject builder castToLabel "feedback"--- --- case result of--- True -> webViewGoForward webView--- _ -> labelSetMarkupTemporary feedbackLabel "<span foreground=\"red\">Unable to go forward !</span>" 5000 >> return ()--- --- where--- webView = mWebView $ mGUI browser--- builder = mBuilder $ mGUI browser--- ----- | Same as goBack function from Hbro.Core,----- but with feedback in case of failure.---goBack :: Browser -> IO ()---goBack browser = do--- result <- webViewCanGoBack webView--- feedbackLabel <- builderGetObject builder castToLabel "feedback"--- --- case result of--- True -> webViewGoBack webView--- _ -> labelSetMarkupTemporary feedbackLabel "<span foreground=\"red\">Unable to go back !</span>" 5000 >> return ()--- --- where--- webView = mWebView $ mGUI browser--- builder = mBuilder $ mGUI browser----- | List preceding URIs in dmenu and let the user select which one to load.-goBackList :: WebView -> [String] -> IO (Maybe String)-goBackList webView dmenuOptions = do- list <- webViewGetBackForwardList webView- n <- webBackForwardListGetBackLength list- backList <- webBackForwardListGetBackListWithLimit list n- dmenuList <- mapM itemToEntry backList- selection <- dmenu dmenuOptions $ (T.pack . unlines) (catMaybes dmenuList)-- case words selection of- uri:_ -> return $ Just uri- _ -> return Nothing- ---- | List succeeding URIs in dmenu and let the user select which one to load.-goForwardList :: WebView -> [String] -> IO (Maybe String)-goForwardList webView dmenuOptions = do- list <- webViewGetBackForwardList webView- n <- webBackForwardListGetForwardLength list- forwardList <- webBackForwardListGetForwardListWithLimit list n- dmenuList <- mapM itemToEntry forwardList- selection <- dmenu dmenuOptions $ (T.pack . unlines) (catMaybes dmenuList)- - case words selection of- uri:_ -> return $ Just uri- _ -> return Nothing---itemToEntry :: WebHistoryItem -> IO (Maybe String)-itemToEntry item = do- title <- webHistoryItemGetTitle item- uri <- webHistoryItemGetUri item- case uri of- Just u -> return $ Just (u ++ " | " ++ (maybe "Untitled" id title))- _ -> return Nothing----- | Toggle source display.--- Current implementation forces a refresh of current web page, which may be undesired.-toggleSourceMode :: WebView -> IO ()-toggleSourceMode webView = do- currentMode <- webViewGetViewSourceMode webView- webViewSetViewSourceMode webView (not currentMode)- webViewReload webView
− Hbro/Extra/Session.hs
@@ -1,60 +0,0 @@-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 :: WebView -> String -> IO ()-setupSession webView sessionDirectory = do- pid <- getProcessID- previousSession <- getDirectoryContents sessionDirectory-- let sessionFile = sessionDirectory ++ 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 ()-----loadFromSession :: [String] -> String -> IO ()---loadFromSession dmenuOptions sessionDirectory = do--- previousSession <- getDirectoryContents sessionDirectory--- sessionURIs <- mapM getSessionURI previousSession --- --- selection <- dmenu dmenuOptions (T.unlines sessionURIs)--- --- case selection of--- "" -> return ()--- u -> do--- _ <- spawn "hbro" ["-u", u]--- return ()--- ---getSessionURI :: String -> IO T.Text---getSessionURI fileName = do--- configHome <- getEnv "XDG_CONFIG_HOME"--- file <- T.readFile $ configHome ++ "/hbro/sessions/" ++ fileName--- --- return $ (head . T.lines) file-
− Hbro/Extra/StatusBar.hs
@@ -1,170 +0,0 @@-module Hbro.Extra.StatusBar where---- {{{ Imports---import Hbro.Keys-import Hbro.Types---import Hbro.Util ----import Control.Monad.Trans(liftIO)--import Data.List--import Graphics.Rendering.Pango.Enums-import Graphics.Rendering.Pango.Layout--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 Network.URL--import System.Glib.Signals--- }}}----- | Write current scroll position in the given Label.-setupScrollWidget :: Label -> ScrolledWindow -> IO ()-setupScrollWidget widget window = do- labelSetAttributes widget [- AttrForeground {paStart = 0, paEnd = -1, paColor = Color 32767 32767 32767}- ]- - adjustment <- scrolledWindowGetVAdjustment window-- _ <- onValueChanged adjustment $ do- current <- adjustmentGetValue adjustment- lower <- adjustmentGetLower adjustment- upper <- adjustmentGetUpper adjustment- page <- adjustmentGetPageSize adjustment- - case upper-lower-page of- 0 -> labelSetText widget "ALL"- x -> labelSetText widget $ show (round $ current/x*100) ++ "%"-- labelSetText widget "0%"----- | /!\ Doesn't work for now.--- Write current zoom level in the given Label.-statusBarZoomLevel :: Label -> WebView -> IO ()-statusBarZoomLevel widget webView = do- zoomLevel <- webViewGetZoomLevel webView- - labelSetMarkup widget $ "<span foreground=\"white\">x" ++ escapeMarkup (show zoomLevel) ++ "</span>"- ---- | -withFeedback :: Label -> KeyEventCallback -> [Modifier] -> String -> IO Bool-withFeedback widget callback modifiers keys = do --- Trigger callback- result <- callback modifiers keys- --- Set color depending on result- let color = case result of- True -> Color 0 65535 0- _ -> Color 65535 0 0- - labelSetAttributes widget [- AttrForeground {paStart = 0, paEnd = -1, paColor = color}- ]- --- Write keystrokes state to label- case (modifiers, isSuffixOf "<Escape>" keys) of- (_ , True) -> labelSetText widget []- ([], _) -> labelSetText widget keys- (_, _) -> labelSetText widget (show modifiers ++ keys)- - return result- ---- | Write current load progress in the given Label.-statusBarLoadProgress :: Label -> WebView -> IO ()-statusBarLoadProgress widget webView = do--- Load started- _ <- on webView loadStarted $ \_ -> do- labelSetAttributes widget [- AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0}- ]- labelSetText widget "0%"--- Progress changed - _ <- on webView progressChanged $ \progress' -> do- labelSetAttributes widget [- AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 65535 0}- ]- labelSetText widget $ show progress' ++ "%"--- Load finished- _ <- on webView loadFinished $ \_ -> do- labelSetAttributes widget [- AttrForeground {paStart = 0, paEnd = -1, paColor = Color 0 65535 0}- ]- labelSetText widget "100%"--- Error- _ <- on webView loadError $ \_ _ _ -> do- labelSetAttributes widget [- AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0}- ]- labelSetText widget "ERROR"- return False- - return ()----- | Write current URI, or the destination of a hovered link, in the given Label.-statusBarURI :: Label -> WebView -> IO ()-statusBarURI widget webView = do--- URI changed- _ <- on webView loadCommitted $ \_ -> do- getUri <- (webViewGetUri webView) - maybe (return ()) (flip setURILabel widget) getUri---- Hovering link- _ <- on webView hoveringOverLink $ \_title hoveredUri -> do- getUri <- (webViewGetUri webView)- let uri = case (hoveredUri, getUri) of- (Just u, _) -> u- (_, Just u) -> u- (_, _) -> "ERROR"- - setURILabel uri widget- - return ()-- where- setURILabel uri label = do- let uri' = importURL uri- case uri' of- Just u -> do- case url_type u of- Absolute host_ -> do- let host' = exportHost host_- let secure' = secure host_- let protocolColor = Color 20000 20000 20000- let hostColor = case secure' of- True -> Color 0 65535 0- _ -> Color 50000 50000 50000- let pathColor = Color 20000 20000 65535- let parametersColor = Color 20000 20000 20000- let i = findIndex (isPrefixOf "://") (tails host')- let j = length host'- - - let colorAttributes = case i of- Just n -> [- AttrForeground {paStart = 0, paEnd = n+3, paColor = protocolColor},- AttrForeground {paStart = n+3, paEnd = j, paColor = hostColor},- AttrForeground {paStart = j, paEnd = -1, paColor = pathColor}- ]- _ -> [- AttrForeground {paStart = 0, paEnd = j, paColor = hostColor},- AttrForeground {paStart = j, paEnd = -1, paColor = pathColor}- ]- - - labelSetAttributes label $ [AttrWeight {paStart = 0, paEnd = -1, paWeight = WeightBold}] ++ colorAttributes- - labelSetText label uri- _ -> return ()- _ -> return ()-
Hbro/Gui.hs view
@@ -8,11 +8,14 @@ ) where -- {{{ Imports+import Hbro.Util import Hbro.Types -import Control.Monad+import Control.Monad hiding(forM_, mapM_) import Control.Monad.Trans +import Data.Foldable+ import Graphics.Rendering.Pango.Enums import Graphics.UI.Gtk.Abstract.Container import Graphics.UI.Gtk.Abstract.Box@@ -27,17 +30,17 @@ import Graphics.UI.Gtk.Layout.VBox import Graphics.UI.Gtk.Scrolling.ScrolledWindow import Graphics.UI.Gtk.WebKit.WebInspector-import Graphics.UI.Gtk.WebKit.WebFrame import Graphics.UI.Gtk.WebKit.WebSettings-import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.WebKit.WebView hiding(webViewLoadUri) import Graphics.UI.Gtk.Windows.Window +import Prelude hiding(mapM_)+ import System.Console.CmdArgs (whenNormal, whenLoud) import System.Glib.Attributes import System.Glib.Signals -- }}} - initGUI :: FilePath -> [AttrOp WebSettings] -> IO GUI initGUI xmlPath settings = do whenNormal $ putStr ("Loading GUI from " ++ xmlPath ++ "... ")@@ -47,7 +50,7 @@ builder <- builderNew builderAddFromFile builder xmlPath --- Init components+-- Initialize components (webView, sWindow) <- initWebView builder settings (window, wBox) <- initWindow builder webView promptBar <- initPromptBar builder@@ -59,32 +62,41 @@ widgetHide (mBox promptBar) whenNormal $ putStrLn "Done."- return $ GUI window inspectorWindow sWindow webView promptBar statusBar builder+ return $ GUI { + mWindow = window, + mInspectorWindow = inspectorWindow, + mScrollWindow = sWindow, + mWebView = webView, + mPromptBar = promptBar, + mStatusBar = statusBar, + mBuilder = builder+ } initWebView :: Builder -> [AttrOp WebSettings] -> IO (WebView, ScrolledWindow) initWebView builder settings = do- webView <- webViewNew+-- Initialize ScrolledWindows+ window <- builderGetObject builder castToScrolledWindow "webViewParent"+ scrolledWindowSetPolicy window PolicyNever PolicyNever+ +-- Initialize WebSettings webSettings <- webSettingsNew- set webSettings settings +-- Initialize WebView+ webView <- webViewNew set webView [ widgetCanDefault := True ]- _ <- on webView closeWebView $ GTK.mainQuit >> return False webViewSetWebSettings webView webSettings- + containerAdd window webView+ +-- + _ <- on webView closeWebView $ GTK.mainQuit >> return False+ -- On new window request _ <- on webView createWebView $ \frame -> do- newUri <- webFrameGetUri frame- case newUri of- Just uri -> do- whenLoud $ putStrLn ("Requesting new window: " ++ uri ++ "...")- webViewLoadUri webView uri- Nothing -> return ()+ webFrameGetUri frame >>= (mapM_ (\uri -> do+ whenLoud $ putStrLn ("Requesting new window: " ++ show uri ++ "...")+ webViewLoadUri webView uri)) return webView- - window <- builderGetObject builder castToScrolledWindow "webViewParent"- containerAdd window webView - scrolledWindowSetPolicy window PolicyNever PolicyNever return (webView, window)
+ Hbro/Hbro.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DoRec #-}+module Hbro.Hbro (+-- * Main+ defaultConfig,+ launchHbro+) where++-- {{{ Imports+import Hbro.Core+import Hbro.Gui+import Hbro.Keys+import Hbro.Socket+import Hbro.Types+import Hbro.Util++import qualified Config.Dyre as D+import Config.Dyre.Paths++import Control.Concurrent+import Control.Monad.Reader++import qualified Data.Map as M++import Graphics.UI.Gtk.Abstract.Widget+import Graphics.UI.Gtk.General.General hiding(initGUI)+import Graphics.UI.Gtk.WebKit.WebView hiding(webViewGetUri, webViewLoadUri)+import Graphics.UI.Gtk.WebKit.Download++import Network.URI++import System.Console.CmdArgs+import System.Directory+import System.Environment.XDG.BaseDir+import System.FilePath+import System.Glib.Signals+import System.IO+import System.Posix.Process+import System.Posix.Signals+import qualified System.ZMQ as ZMQ+-- }}}++-- {{{ Commandline options+cliOptions :: CliOptions+cliOptions = CliOptions {+ mURI = def &= help "URI to open at start-up" &= explicit &= name "u" &= name "uri" &= typ "URI",+ mVanilla = def &= help "Do not read custom configuration file." &= explicit &= name "1" &= name "vanilla",+ mDenyReconf = def &= help "Deny recompilation even if the configuration file has changed." &= explicit &= name "deny-reconf",+ mForceReconf = def &= help "Force recompilation even if the configuration file hasn't changed." &= explicit &= name "force-reconf",+ mDyreDebug = def &= help "Force the application to use './cache/' as the cache directory, and ./ as the configuration directory. Useful to debug the program without installation." &= explicit &= name "dyre-debug",+ mMasterBinary = def &= explicit &= name "dyre-master-binary"+}++getOptions :: IO CliOptions+getOptions = cmdArgs $ cliOptions+ &= verbosityArgs [explicit, name "verbose", name "v"] []+ &= versionArg [ignore]+ &= help "A minimal KISS-compliant browser."+ &= helpArg [explicit, name "help", name "h"]+ &= program "hbro"+-- }}}++-- {{{ Configuration (Dyre)+dyreParameters :: D.Params (Config, CliOptions)+dyreParameters = D.defaultParams {+ D.projectName = "hbro",+ D.showError = showError,+ D.realMain = realMain,+ D.ghcOpts = ["-threaded"],+ D.statusOut = hPutStrLn stderr+}++showError :: (Config, a) -> String -> (Config, a)+showError (config, x) message = (config { mError = Just message }, x)++-- | Default configuration.+-- Homepage: Google, socket directory: /tmp,+-- UI file: ~/.config/hbro/, no key/command binding.+defaultConfig :: CommonDirectories -> Config+defaultConfig directories = Config {+ mCommonDirectories = directories,+ mHomePage = "https://encrypted.google.com/",+ mSocketDir = mTemporary directories,+ mUIFile = (mConfiguration directories) </> "ui.xml",+ mKeyEventHandler = simpleKeyEventHandler,+ mKeyEventCallback = \_ -> simpleKeyEventCallback (keysListToMap []),+ mWebSettings = [],+ mSetup = const (return () :: IO ()),+ mCommands = [],+ mDownloadHook = \_ _ _ _ -> return (),+ mError = Nothing+}+-- }}}++-- {{{ Entry point+-- | Browser's main function.+-- To be called in main function with a proper configuration.+-- See Hbro.Main for an example.+launchHbro :: (CommonDirectories -> Config) -> IO ()+launchHbro configGenerator = do+ homeDir <- getHomeDirectory+ tmpDir <- getTemporaryDirectory+ configDir <- getUserConfigDir "hbro"+ dataDir <- getUserDataDir "hbro"+ + let config = configGenerator (CommonDirectories homeDir tmpDir configDir dataDir)++ options <- getOptions+ case mVanilla options of+ True -> D.wrapMain dyreParameters{ D.configCheck = False } (config, options)+ _ -> D.wrapMain dyreParameters (config, options)++realMain :: (Config, CliOptions) -> IO ()+realMain (config, options) = do+-- Print configuration error, if any+ maybe (return ()) putStrLn $ mError config++-- Print in-use paths+ whenLoud $ getPaths dyreParameters >>= \(a,b,c,d,e) -> (putStrLn . unlines) [+ "Current binary: " ++ a,+ "Custom binary: " ++ b,+ "Config file: " ++ c,+ "Cache directory: " ++ d,+ "Lib directory: " ++ e,+ []]+ +-- Initialize GUI+ gui <- initGUI (mUIFile config) (mWebSettings config)++-- Initialize IPC socket+ ZMQ.withContext 1 $ realMain' config options gui++realMain' :: Config -> CliOptions -> GUI -> ZMQ.Context -> IO ()+realMain' config options gui@GUI {mWebView = webView, mWindow = window} context = let+ environment = Environment options config gui context+ setup = mSetup config+ socketDir = mSocketDir config + commands = mCommands config+ keyEventHandler = mKeyEventHandler config+ keyEventCallback = (mKeyEventCallback config) environment+ in do+-- Apply custom setup+ setup environment+ +-- Bind download hook+ void $ on webView downloadRequested $ \download -> do+ uri <- (>>= parseURI) `fmap` downloadGetUri download+ filename <- downloadGetSuggestedFilename download+ size <- downloadGetTotalSize download+ + case (uri, filename) of+ (Just uri', Just filename') -> do+ whenNormal $ putStrLn ("Requested download: " ++ show uri')+ (mDownloadHook config) environment uri' filename' size+ _ -> return ()+ return False+ +-- Setup key handler+ rec i <- after webView keyPressEvent $ keyEventHandler keyEventCallback i webView++-- Load homepage+ startURI <- case (mURI options) of+ Just uri -> do + fileURI <- doesFileExist uri+ case fileURI of+ True -> getCurrentDirectory >>= \dir -> return $ Just ("file://" ++ dir </> uri)+ _ -> return $ Just uri+ _ -> return Nothing+ + maybe (goHome webView config) (webViewLoadUri webView) (startURI >>= parseURIReference)++-- Open socket+ pid <- getProcessID+ let commandsList = M.fromList $ defaultCommandsList ++ commands+ let socketURI = "ipc://" ++ socketDir ++ pathSeparator:"hbro." ++ show pid+ void $ forkIO (openRepSocket context socketURI (listenToCommands environment commandsList))+ +-- Manage POSIX signals+ void $ installHandler sigINT (Catch interruptHandler) Nothing++ --timeoutAdd (putStrLn "OK" >> return True) 2000+ mainGUI -- Main loop++-- Make sure response socket is closed at exit+ whenLoud $ putStrLn "Closing socket..."+ closeSocket context socketURI+ whenNormal $ putStrLn "Exiting..."++interruptHandler :: IO ()+interruptHandler = whenLoud (putStrLn "Received SIGINT.") >> mainQuit+-- }}}
Hbro/Main.hs view
@@ -1,7 +1,7 @@ module Main where -- {{{ Imports-import Hbro.Core+import Hbro.Hbro import Hbro.Types import Paths_hbro
Hbro/Socket.hs view
@@ -4,16 +4,22 @@ import Hbro.Util import Hbro.Types -import Control.Monad-import Control.Monad.Reader+import Control.Monad hiding(mapM_)+import Control.Monad.Reader hiding(mapM_) import Data.ByteString.Char8 (pack, unpack)+import Data.Foldable import qualified Data.Map as Map import Graphics.UI.Gtk.General.General-import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.WebKit.WebView hiding(webViewGetUri, webViewLoadUri) +import Network.URI++import Prelude hiding(mapM_)+ import System.Console.CmdArgs (whenNormal, whenLoud)+import System.FilePath import System.ZMQ -- }}} @@ -49,28 +55,26 @@ listenToCommands environment commands repSocket ---- | Close the response socket by sending it the command "Quit".+-- | Close the response socket by sending it the command "QUIT". -- Typically called when exiting application. closeSocket :: Context -> String -> IO () closeSocket context socketURI = void $ sendCommand context socketURI "QUIT" -- | Return the socket path to use for the given browser's process ID.-processIDToSocket :: String -> String -> String-processIDToSocket pid socketDir = "ipc://" ++ socketDir ++ "/hbro." ++ pid+socketFile :: String -> String -> String+socketFile pid socketDir = "ipc://" ++ socketDir </> "hbro." ++ pid -- | Send a single command (through a Request socket) to the given Response socket, -- and return the answer. sendCommand :: Context -> String -> String -> IO String-sendCommand context socketURI command = do- withSocket context Req $ \reqSocket -> do- connect reqSocket socketURI- send reqSocket (pack command) []- receive reqSocket [] >>= return . unpack+sendCommand context socketURI command = withSocket context Req $ \reqSocket -> do+ connect reqSocket socketURI+ send reqSocket (pack command) []+ receive reqSocket [] >>= return . unpack -- | Same as 'sendCommand', but for all running instances of the browser. sendCommandToAll :: Context -> FilePath -> String -> IO [String]-sendCommandToAll context socketDir command = getAllProcessIDs >>= mapM (\pid -> sendCommand context (processIDToSocket pid socketDir) command)+sendCommandToAll context socketDir command = getAllProcessIDs >>= mapM (\pid -> sendCommand context (socketFile pid socketDir) command) -- | List of default supported requests. defaultCommandsList :: CommandsList@@ -79,7 +83,7 @@ ("GET_URI", \_arguments repSocket browser -> liftIO $ do getUri <- postGUISync $ webViewGetUri (mWebView $ mGUI browser) case getUri of- Just uri -> send repSocket (pack uri) []+ Just uri -> send repSocket ((pack . show) uri) [] _ -> send repSocket (pack "ERROR No URL opened") [] ), ("GET_TITLE", \_arguments repSocket browser -> liftIO $ do@@ -102,7 +106,7 @@ -- Trigger actions ("LOAD_URI", \arguments repSocket browser -> liftIO $ case arguments of uri:_ -> do- postGUIAsync $ webViewLoadUri (mWebView $ mGUI browser) uri+ postGUIAsync $ mapM_ (webViewLoadUri (mWebView (mGUI browser))) (parseURIReference uri) send repSocket (pack "OK") [] _ -> send repSocket (pack "ERROR: argument needed.") [] ),
Hbro/Types.hs view
@@ -16,6 +16,8 @@ import Graphics.UI.Gtk.WebKit.WebView import Graphics.UI.Gtk.Windows.Window +import Network.URI+ import System.Console.CmdArgs import System.Glib.Attributes import System.Glib.Signals@@ -51,16 +53,17 @@ data Config = {-forall a.-} Config {- mCommonDirectories :: CommonDirectories, -- ^ Custom directories used to store various runtime and static files- mHomePage :: String, -- ^ Startup page - mSocketDir :: FilePath, -- ^ Directory where 0MQ will be created ("/tmp" for example)- mUIFile :: FilePath, -- ^ Path to XML file describing UI (used by GtkBuilder)+ mCommonDirectories :: CommonDirectories, -- ^ Custom directories used to store various runtime and static files+ mHomePage :: String, -- ^ Startup page + mSocketDir :: FilePath, -- ^ Directory where 0MQ will be created ("/tmp" for example)+ mUIFile :: FilePath, -- ^ Path to XML file describing UI (used by GtkBuilder) mKeyEventHandler :: KeyEventCallback -> ConnectId WebView -> WebView -> EventM EKey Bool, -- ^ Key event handler, which forwards keystrokes to mKeyEventCallback- mKeyEventCallback :: Environment -> KeyEventCallback, -- ^ Main key event callback, assumed to deal with each keystroke separately- mWebSettings :: [AttrOp WebSettings], -- ^ WebSettings' attributes to use with webkit (see Webkit.WebSettings documentation)- mSetup :: Environment -> IO (), -- ^ Custom startup instructions- mCommands :: CommandsList, -- ^ Custom commands to use with IPC sockets- mError :: Maybe String -- ^ Error+ mKeyEventCallback :: Environment -> KeyEventCallback, -- ^ Main key event callback, assumed to deal with each keystroke separately+ mWebSettings :: [AttrOp WebSettings], -- ^ WebSettings' attributes to use with webkit (see Webkit.WebSettings documentation)+ mSetup :: Environment -> IO (), -- ^ Custom startup instructions+ mCommands :: CommandsList, -- ^ Custom commands to use with IPC sockets+ mDownloadHook :: Environment -> URI -> String -> Int -> IO (), -- ^ Function triggered on a download request+ mError :: Maybe String -- ^ Error --mCustom :: a } @@ -69,8 +72,8 @@ mInspectorWindow :: Window, -- ^ WebInspector window mScrollWindow :: ScrolledWindow, -- ^ ScrolledWindow containing the webview mWebView :: WebView, -- ^ Browser's webview- mPromptBar :: PromptBar, - mStatusBox :: HBox, -- ^ Status bar's horizontal box+ mPromptBar :: PromptBar, -- ^ Prompt bar+ mStatusBar :: HBox, -- ^ Status bar's horizontal box mBuilder :: Builder -- ^ Builder object created from XML file } @@ -82,7 +85,7 @@ -- | List of bound keys.--- All callbacks are fed with the Browser instance.+-- All callbacks are fed with the Environment instance. -- -- Note 1 : for modifiers, lists are used for convenience purposes, -- but are transformed into sets in hbro's internal machinery,
Hbro/Util.hs view
@@ -1,11 +1,15 @@ module Hbro.Util ( -- * Process management- runCommand', spawn, getAllProcessIDs,+-- * WebKit functions redefinition+ webFrameGetUri,+ webViewGetUri,+ webViewLoadUri, -- * Misc labelSetMarkupTemporary,- dmenu+ dmenu,+ errorHandler ) where -- {{{ Imports@@ -15,34 +19,33 @@ import Control.Monad import Data.List-import qualified Data.Text as T-import qualified Data.Text.IO as T+import Data.IORef import Graphics.UI.Gtk.Display.Label import Graphics.UI.Gtk.General.General+import qualified Graphics.UI.Gtk.WebKit.WebFrame as WebKit+import qualified Graphics.UI.Gtk.WebKit.WebView as WebKit +import Network.URI++import System.Console.CmdArgs import qualified System.Info as Sys import System.IO+import System.IO.Error import System.Posix.Process import System.Process -- }}} -- {{{ Process management--- | Like run `runCommand`, but return IO ()-runCommand' :: String -> IO ()-runCommand' command = runCommand command >> return ()- -- | 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` spawn :: String -> [String] -> IO () spawn command options = spawn' (proc command options) 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 () +-- | Return the list of process IDs corresponding to all running instances of the browser. getAllProcessIDs :: IO [FilePath] getAllProcessIDs = do (_, pids, _) <- readProcessWithExitCode "pidof" ["hbro"] []@@ -52,28 +55,54 @@ return $ delete (show myPid) . nub . words $ pids ++ " " ++ pids' -- }}} +-- {{{ Webkit functions redefinition+-- | Replacement for Graphics.UI.Gtk.WebKit.WebFrame(webFrameGetUri), using the Network.URI type.+webFrameGetUri :: WebKit.WebFrame -> IO (Maybe URI)+webFrameGetUri frame = (>>= parseURI) `fmap` WebKit.webFrameGetUri frame++-- | Replacement for Graphics.UI.Gtk.WebKit.WebView(webViewGetUri), using the Network.URI type.+webViewGetUri :: WebKit.WebView -> IO (Maybe URI)+webViewGetUri webView = (>>= parseURI) `fmap` WebKit.webViewGetUri webView++-- | Replacement for Graphics.UI.Gtk.WebKit.WebView(webViewLoadUri), using the Network.URI type.+webViewLoadUri :: WebKit.WebView -> URI -> IO ()+webViewLoadUri webView uri = do+ whenLoud $ putStrLn ("Loading URI: " ++ show uri)+ case uriScheme uri of+ [] -> WebKit.webViewLoadUri webView ("http://" ++ show uri)+ _ -> WebKit.webViewLoadUri webView (show uri)+-- }}}+ -- | Set a temporary markup text to a label that disappears after some delay.-labelSetMarkupTemporary :: Label -> String -> Int -> IO HandlerId-labelSetMarkupTemporary label text delay = do+labelSetMarkupTemporary :: {-IORef HandlerId ->-} Label -> String -> Int -> IO ()+labelSetMarkupTemporary {-x-} label text delay = do+ --handler <- readIORef x+ --timeoutRemove handler+ labelSetMarkup label text- timeoutAdd clear delay+ timeoutAdd (clear >> return False) delay >> return () -- >>= writeIORef x where- clear = labelSetMarkup label "" >> return False---- | Similar to forM_ (from Control.Monad) but for Maybe instead of List.-forMaybeM_ :: Maybe a -> (a -> IO ()) -> IO ()-forMaybeM_ = flip $ maybe (return ())+ clear = labelSetMarkup label "" -- | Open dmenu with given input and return selected entry.-dmenu :: [String] -- ^ dmenu's commandline options- -> T.Text -- ^ dmenu's input- -> IO String -- ^ Selected entry+dmenu :: [String] -- ^ dmenu's commandline options+ -> String -- ^ dmenu's input+ -> IO (Maybe String) -- ^ Selected entry dmenu options input = do (in_, out, err, pid) <- runInteractiveProcess "dmenu" options Nothing Nothing- T.hPutStr in_ input- hClose in_+ hPutStr in_ input+ hClose in_ - output <- catch (hGetLine out) $ \_error -> return []+ output <- try $ hGetLine out + let output' = case output of+ Left _ -> Nothing+ Right x -> Just x hClose out >> hClose err >> (void $ waitForProcess pid)- return output+ return output'++errorHandler :: FilePath -> IOError -> IO ()+errorHandler file e = do+ when (isAlreadyInUseError e) $ (whenNormal . putStrLn) ("ERROR: file <" ++ file ++ "> is already opened and cannot be reopened.")+ when (isDoesNotExistError e) $ (whenNormal . putStrLn) ("ERROR: file <" ++ file ++ "> doesn't exist.")+ when (isPermissionError e) $ (whenNormal . putStrLn) ("ERROR: user doesn't have permission to open file <" ++ file ++ ">.")
README.rst view
@@ -83,7 +83,7 @@ Configuration ------------- -By default, a pretty limited configuration file (see ``Hbro/Main.hs``) is used to build *hbro*. You can create your own at ``~/.config/hbro/hbro.hs`` to override it. A featured and self-explanatory example of configuration file is provided at ``example/hbro.hs``.+By default, a pretty limited configuration file (see ``Hbro/Main.hs``) is used to build *hbro*. You can create your own at ``~/.config/hbro/hbro.hs`` to override it. Several extensions are provided with the *hbro-contrib_* package, including a featured and self-explanatory example of configuration file. Known bugs and limitations@@ -116,3 +116,4 @@ .. _ZeroMQ: http://www.zeromq.org/ .. _Dyre: https://github.com/willdonnelly/dyre .. _webkit_get_default_session: http://webkitgtk.org/reference/webkitgtk/stable/webkitgtk-Global-functions.html+.. _hbro-contrib: http://hackage.haskell.org/package/hbro-contrib
− examples/hbro.hs
@@ -1,320 +0,0 @@-{-# LANGUAGE DoRec #-}-module Main where---- {{{ Imports-import Hbro.Core-import qualified Hbro.Extra.Bookmarks as Bookmarks-import qualified Hbro.Extra.BookmarksQueue as Queue-import Hbro.Extra.Clipboard-import qualified Hbro.Extra.History as History-import Hbro.Extra.Misc-import Hbro.Extra.Session-import Hbro.Extra.StatusBar-import Hbro.Gui-import Hbro.Keys-import Hbro.Socket-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-import Graphics.UI.Gtk.General.General-import Graphics.UI.Gtk.WebKit.Download-import Graphics.UI.Gtk.WebKit.NetworkRequest-import Graphics.UI.Gtk.WebKit.WebNavigationAction-import Graphics.UI.Gtk.WebKit.WebPolicyDecision-import Graphics.UI.Gtk.WebKit.WebSettings-import Graphics.UI.Gtk.WebKit.WebView-import Graphics.UI.Gtk.Windows.Window--import System.Directory-import System.Environment-import System.Environment.XDG.BaseDir-import System.Glib.Attributes-import System.Glib.Signals--- import System.Posix.Process-import System.Process --- }}}---- Main function, expected to call launchHbro.--- You can add custom tasks before & after calling it.-main :: IO ()-main = launchHbro myConfig---- A structure containing your configuration settings, overriding--- fields in the default config. Any you don't override, will --- use the defaults defined in Hbro.Types.Parameters.-myConfig :: CommonDirectories -> Config-myConfig directories = (defaultConfig directories) {- mSocketDir = mySocketDirectory directories,- mUIFile = myUIFile directories,- mKeyEventHandler = myKeyEventHandler,- mKeyEventCallback = myKeyEventCallback,- mHomePage = myHomePage,- mWebSettings = myWebSettings,- mSetup = mySetup-}---- Various constant parameters-myHomePage = "https://duckduckgo.com"--mySocketDirectory :: CommonDirectories -> FilePath-mySocketDirectory directories = mTemporary directories--myUIFile :: CommonDirectories -> FilePath-myUIFile directories = (mConfiguration directories) ++ "/ui.xml"--myHistoryFile :: CommonDirectories -> FilePath-myHistoryFile directories = (mData directories) ++ "/history"--myBookmarksFile :: CommonDirectories -> FilePath-myBookmarksFile directories = (mData directories) ++ "/bookmarks"---- How to download files-myDownload :: CommonDirectories -> String -> String -> IO ()-myDownload directories uri name = spawn "aria2c" [uri, "-d", (mHome directories) ++ "/", "-o", name]---myDownload directories uri name = spawn "wget" [uri, "-O", (mHome directories) ++ "/" ++ name]---myDownload directories uri name = spawn "axel" [uri, "-o", (mHome directories) ++ "/" ++ name]- -myKeyEventHandler :: KeyEventCallback -> ConnectId WebView -> WebView -> EventM EKey Bool-myKeyEventHandler = advancedKeyEventHandler--myKeyEventCallback :: Environment -> KeyEventCallback-myKeyEventCallback environment@Environment{ mGUI = gui } modifiers keys = do- keysLabel <- builderGetObject builder castToLabel "keys"- withFeedback keysLabel (simpleKeyEventCallback $ keysListToMap (myKeys environment)) modifiers keys- where- builder = mBuilder gui----- {{{ Keys--- Note that this example is suited for an azerty keyboard.-myKeys :: Environment -> KeysList-myKeys environment@Environment{ mGUI = gui, mConfig = config, mContext = context } = let- window = mWindow gui- webView = mWebView gui- scrolledWindow = mScrollWindow gui- statusBox = mStatusBox gui- promptBar = mPromptBar gui- promptEntry = mEntry promptBar- bookmarksFile = myBookmarksFile (mCommonDirectories config)- historyFile = myHistoryFile (mCommonDirectories config)- socketDir = mSocketDir config- in - [--- ((modifiers, key), callback)--- Browse- (([Control], "<Left>"), webViewGoBack webView),- (([Control], "<Right>"), webViewGoForward webView),- (([Alt], "<Left>"), (goBackList webView ["-l", "10"]) >>= maybe (return ()) (loadURI webView)),- (([Alt], "<Right>"), (goForwardList webView ["-l", "10"]) >>= maybe (return ()) (loadURI webView)),- (([Control], "s"), webViewStopLoading webView),- (([], "<F5>"), webViewReload webView),- (([Control], "<F5>"), webViewReloadBypassCache webView),- (([Control], "^"), goLeft scrolledWindow),- (([Control], "$"), goRight scrolledWindow),- (([Control], "<Home>"), goTop scrolledWindow),- (([Control], "<End>"), goBottom scrolledWindow),- (([Alt], "<Home>"), goHome webView config),- (([Control], "g"), prompt "Google search" "" (\words -> loadURI webView ("https://www.google.com/search?q=" ++ words)) gui),---- Display- (([Control, Shift], "+"), webViewZoomIn webView),- (([Control], "-"), webViewZoomOut webView),- (([], "<F11>"), windowFullscreen window),- (([], "<Escape>"), windowUnfullscreen window),- (([Control], "b"), toggleVisibility statusBox),- (([Control], "u"), toggleSourceMode webView),---- Prompt- (([Control], "o"), prompt "Open URL " "" (loadURI webView) gui),- (([Control, Shift], "O"), webViewGetUri webView >>= maybe (return ()) (\uri -> prompt "Open URL " uri (loadURI webView) gui)),---- Search- (([Shift], "/"), promptIncremental "Search " "" (\word -> webViewSearchText webView word False True True >> return ()) gui),- (([Control], "f"), promptIncremental "Search " "" (\word -> webViewSearchText webView word False True True >> return ()) gui),- (([Shift], "?"), promptIncremental "Search " "" (\word -> webViewSearchText webView word False False True >> return ()) gui),- (([Control], "n"), entryGetText promptEntry >>= \word -> webViewSearchText webView word False True True >> return ()),- (([Control, Shift], "N"), entryGetText promptEntry >>= \word -> webViewSearchText webView word False False True >> return ()),---- Copy/paste- (([Control], "y"), webViewGetUri webView >>= maybe (return ()) toClipboard),- (([Control, Shift], "Y"), webViewGetTitle webView >>= maybe (return ()) toClipboard),- (([Control], "p"), withClipboard $ maybe (return ()) (loadURI webView)),- (([Control, Shift], "P"), withClipboard $ maybe (return ()) (\uri -> spawn "hbro" ["-u", uri])),---- Misc- (([], "<Escape>"), widgetHide $ mBox promptBar),- (([Control], "i"), showWebInspector webView),- (([Alt], "p"), printPage webView),- (([Control], "t"), spawn "hbro" []),- (([Control], "w"), mainQuit),---- Bookmarks- (([Control], "d"), webViewGetUri webView >>= maybe (return ()) (\uri -> prompt "Bookmark with tags:" "" (\tags -> Bookmarks.add bookmarksFile uri (words tags)) gui)),- (([Control, Shift], "D"), prompt "Bookmark all instances with tag:" "" (\tags -> sendCommandToAll context socketDir "GET_URI" >>= mapM (\uri -> Bookmarks.add bookmarksFile uri $ words tags) >> (webViewGetUri webView) >>= maybe (return ()) (\uri -> Bookmarks.add bookmarksFile uri $ words tags) >> return ()) gui),- (([Alt], "d"), Bookmarks.deleteWithTag bookmarksFile ["-l", "10"]),- (([Control], "l"), Bookmarks.select bookmarksFile ["-l", "10"] >>= maybe (return ()) (loadURI webView)),- (([Control, Shift], "L"), Bookmarks.selectTag bookmarksFile ["-l", "10"] >>= maybe (return ()) (\uris -> mapM (\uri -> spawn "hbro" ["-u", uri]) uris >> return ())),--- (([Control], "q"), webViewGetUri webView >>= maybe (return ()) (Queue.append),--- (([Alt], "q"), \b -> do--- uri <- Queue.popFront--- loadURI uri b),---- History- (([Control], "h"), History.select historyFile ["-l", "10"] >>= maybe (return ()) (loadURI webView))- --- Session- --(([Alt], "l"), loadFromSession ["-l", "10"])- ]--- }}}---- {{{ Web settings--- Commented out lines correspond to default values.-myWebSettings :: [AttrOp WebSettings]-myWebSettings = [--- SETTING VALUE - --webSettingsCursiveFontFamily := "serif",- --webSettingsDefaultFontFamily := "sans-serif",- --webSettingsFantasyFontFamily := ,- --webSettingsMonospaceFontFamily := "monospace",- --webSettingsSansFontFamily := "sans-serif",- --webSettingsSerifFontFamily := "serif",- --webSettingsDefaultFontSize := ,- --webSettingsDefaultMonospaceFontSize := 10,- --webSettingsMinimumFontSize := 5,- --webSettingsMinimumLogicalFontSize := 5,- --webSettingsAutoLoadImages := True,- --webSettingsAutoShrinkImages := True,- --webSettingsDefaultEncoding := "iso-8859-1",- --webSettingsEditingBehavior := EditingBehaviorWindows,- --webSettingsEnableCaretBrowsing := False,- webSettingsEnableDeveloperExtras := True,- --webSettingsEnableHtml5Database := True,- --webSettingsEnableHtml5LocalStorage := True,- --webSettingsEnableOfflineWebApplicationCache := True,- webSettingsEnablePlugins := True,- webSettingsEnablePrivateBrowsing := False, -- Experimental- webSettingsEnableScripts := False,- --webSettingsEnableSpellChecking := False,- webSettingsEnableUniversalAccessFromFileUris := True,- webSettingsEnableXssAuditor := True,- --webSettingsEnableSiteSpecificQuirks := False,- --webSettingsEnableDomPaste := False,- --webSettingsEnableDefaultContextMenu := True,- webSettingsEnablePageCache := True,- --webSettingsEnableSpatialNavigation := False,- --webSettingsEnforce96Dpi := ,- webSettingsJSCanOpenWindowAuto := True,- --webSettingsPrintBackgrounds := True,- --webSettingsResizableTextAreas := True,- webSettingsSpellCheckingLang := Just "en_US",- --webSettingsTabKeyCyclesThroughElements := True,- webSettingsUserAgent := "Mozilla/5.0 (X11; Linux x86_64; rv:2.0.1) Gecko/20100101 Firefox/4.0.1"- --webSettingsUserStylesheetUri := Nothing,- --webSettingsZoomStep := 0.1- ]--- }}}---- {{{ Setup-mySetup :: Environment -> IO ()-mySetup environment@Environment{ mGUI = gui, mConfig = config } = - let- builder = mBuilder gui - webView = mWebView gui- scrolledWindow = mScrollWindow gui- window = mWindow gui- directories = mCommonDirectories config- historyFile = myHistoryFile directories- getLabel = builderGetObject builder castToLabel- in do- -- Scroll position in status bar- scrollLabel <- getLabel "scroll"- setupScrollWidget scrollLabel scrolledWindow- - -- Zoom level in status bar- zoomLabel <- getLabel "zoom"- statusBarZoomLevel zoomLabel webView- - -- Load progress in status bar- progressLabel <- getLabel "progress"- statusBarLoadProgress progressLabel webView- - -- Current URI in status bar- uriLabel <- getLabel "uri"- statusBarURI uriLabel webView- - -- Session manager- --setupSession browser-- -- - _ <- on webView titleChanged $ \_ title ->- set window [ windowTitle := ("hbro | " ++ title)]-- -- Download requests- feedbackLabel <- getLabel "feedback"- _ <- on webView downloadRequested $ \download -> do- uri <- downloadGetUri download- name <- downloadGetSuggestedFilename download- size <- downloadGetTotalSize download-- case (uri, name) of- (Just uri', Just name') -> do- myDownload directories 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- _ <- on webView mimeTypePolicyDecisionRequested $ \_ request mimetype policyDecision -> do- show <- webViewCanShowMimeType webView mimetype-- case (show, mimetype) of- (True, _) -> webPolicyDecisionUse policyDecision >> return True- _ -> webPolicyDecisionDownload policyDecision >> return True-- -- History handler- _ <- on webView loadFinished $ \_ -> do- uri <- webViewGetUri webView- title <- webViewGetTitle webView- case (uri, title) of- (Just uri', Just title') -> History.add historyFile uri' title'- _ -> return ()-- -- On navigating to a new URI- -- Return True to forbid navigation, False to allow- _ <- on webView navigationPolicyDecisionRequested $ \_ request action policyDecision -> do- getUri <- networkRequestGetUri request- reason <- webNavigationActionGetReason action- mouseButton <- webNavigationActionGetButton action-- case getUri of- Just ('m':'a':'i':'l':'t':'o':':':address) -> do- putStrLn $ "Mailing to: " ++ address- return True- Just uri -> - case mouseButton of- 1 -> return False -- Left button - 2 -> spawn "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 webView newWindowPolicyDecisionRequested $ \_ request action policyDecision -> do- getUri <- networkRequestGetUri request- case getUri of- Just uri -> (spawn "hbro" ["-u", uri]) >> putStrLn uri- _ -> putStrLn "ERROR: wrong URI given, unable to open window."-- return True-- -- Favicon- --_ <- on webView iconLoaded $ \uri -> do something-- return ()--- }}}
examples/ui.xml view
@@ -39,59 +39,14 @@ <object class="GtkHBox" id="statusBox"> <property name="homogeneous">False</property> <property name="spacing">5</property>- - <child>- <object class="GtkLabel" id="progress"></object>- <packing>- <property name="fill">False</property>- <property name="expand">False</property>- </packing>- </child> <child>- <object class="GtkLabel" id="uri">- <property name="ellipsize">PANGO_ELLIPSIZE_END</property>- <property name="xalign">0</property>- <property name="yalign">0</property>- </object>- </child>-- <child>- <object class="GtkLabel" id="scroll"></object>+ <object class="GtkLabel" id="void"></object> <packing>- <property name="pack-type">GTK_PACK_END</property> <property name="fill">False</property> <property name="expand">False</property> </packing> </child>-- <child>- <object class="GtkLabel" id="zoom"></object>- <packing>- <property name="pack-type">GTK_PACK_END</property>- <property name="fill">False</property>- <property name="expand">False</property>- </packing>- </child>-- <child>- <object class="GtkLabel" id="keys"></object>- <packing>- <property name="pack-type">GTK_PACK_END</property>- <property name="fill">False</property>- <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>@@ -99,7 +54,6 @@ <property name="expand">False</property> </packing> </child>- </object></child> </object> </interface>
hbro.cabal view
@@ -1,5 +1,5 @@ Name: hbro-Version: 0.7.1.1+Version: 0.8.0.0 Synopsis: A minimal KISS compliant browser -- Description: Homepage: http://projects.haskell.org/hbro/@@ -13,7 +13,7 @@ Cabal-version: >=1.8 Build-type: Simple-Extra-source-files: README.rst examples/hbro.hs+Extra-source-files: README.rst Data-files: examples/ui.xml Source-repository head@@ -31,29 +31,21 @@ containers, directory, dyre,+ filepath, glib, gtk, mtl,- old-locale,+ network, pango, process,- text,- time, unix,- url, webkit, xdg-basedir, zeromq-haskell Exposed-modules: Hbro.Core,- Hbro.Extra.Bookmarks,- Hbro.Extra.BookmarksQueue,- Hbro.Extra.Clipboard,- Hbro.Extra.History,- Hbro.Extra.Misc,- Hbro.Extra.Session,- Hbro.Extra.StatusBar, Hbro.Gui,+ Hbro.Hbro, Hbro.Keys, Hbro.Socket, Hbro.Types,