hbro 1.1.2.0 → 1.1.2.1
raw patch · 11 files changed
+116/−80 lines, 11 files
Files
- Hbro/Boot.hs +41/−26
- Hbro/Config.hs +3/−14
- Hbro/Core.hs +2/−1
- Hbro/Dyre.hs +20/−13
- Hbro/Gui.hs +5/−5
- Hbro/Options.hs +2/−9
- Hbro/Prompt.hs +0/−1
- Hbro/Webkit/WebView.hs +0/−1
- README.rst +34/−1
- examples/ui.xml +4/−4
- hbro.cabal +5/−5
Hbro/Boot.hs view
@@ -31,7 +31,7 @@ import Data.Functor import Data.List import qualified Data.Map as M hiding(null)--- import Data.Maybe+import Data.Maybe import Data.Version import Graphics.UI.Gtk.Abstract.Widget@@ -47,6 +47,7 @@ import Prelude hiding(init) +import System.Environment.XDG.BaseDir import System.Exit import System.Glib.Signals import System.Posix.Files@@ -64,54 +65,66 @@ when (opts^.Options.help) $ putStrLn Options.usage >> exitSuccess when (opts^.Options.version) $ putStrLn (showVersion version) >> exitSuccess- when (opts^.Options.verbose) . putStrLn $ "Commandline options: " ++ show opts when (opts^.Options.recompile) $ Dyre.recompile >>= maybe exitSuccess (\e -> putStrLn e >> exitFailure) Dyre.wrap hbro' opts (setup, opts) hbro' :: (K (), CliOptions) -> IO ()-hbro' (customSetup, options) = do+hbro' (customSetup, opts) = do void $ installHandler sigINT (Catch onInterrupt) Nothing - config <- runReaderT initConfig options- gui <- runReaderT initGUI options+ when (opts^.Options.verbose) . putStrLn $ "Commandline options: " ++ show opts ++ "\n" - (result, logs) <- withIPC options $ \ipc -> runK options config gui ipc $ main customSetup+ config <- runReaderT initConfig opts+ gui <- initGUI opts + (result, logs) <- withIPC opts $ \ipc -> runK opts config gui ipc $ main customSetup+ either print return result- unless (options^.Options.quiet) . unless (null logs) $ putStrLn logs- unless (options^.Options.quiet) $ putStrLn "Exiting..."+ unless (opts^.Options.quiet) . unless (null logs) $ putStrLn logs+ unless (opts^.Options.quiet) $ putStrLn "Exiting..." -- {{{ Initialization initConfig :: (MonadBase IO m, OptionsReader m) => m (Config K) initConfig = do options <- readOptions id- return $ id+ return . id . (options^.Options.quiet ? set verbosity Quiet ?? id) . (options^.Options.verbose ? set verbosity Verbose ?? id) $ def -initGUI :: (MonadBase IO m, OptionsReader m) => m (GUI K)-initGUI = do- file <- Options.getUIFile- fallback <- io $ getDataFileName "examples/ui.xml"+initGUI :: (MonadBase IO m) => CliOptions -> m (GUI K)+initGUI opts = do+ result <- runErrorT . (`runReaderT` opts) $ do+ file <- getUIFile+ whenM (readOptions Options.verbose) . io . putStrLn $ "Building GUI from file " ++ file ++ "\n" - file' <- io $ firstReadableOf [file, fallback]+ io $ void GTK.initGUI+ Gui.buildFrom file+ either (\e -> io (putStrLn e >> exitFailure)) return result - case file' of- Just f -> do- io $ void GTK.initGUI- Gui.buildFrom f- _ -> io $ putStrLn "No UI file found." >> exitFailure++getUIFile :: (MonadBase IO m, OptionsReader m, MonadError String m) => m FilePath+getUIFile = do+ fileFromOption <- readOptions Options.uIFile+ fileFromConfig <- io (getUserConfigDir "hbro" >/> "ui.xml")+ fileFromPackage <- io $ getDataFileName "examples/ui.xml"++ maybe+ (throwError "[ERROR] No readable UI file found.")+ return+ =<< io (firstReadableOf . catMaybes $ [fileFromOption, Just fileFromConfig, Just fileFromPackage]) where firstReadableOf [] = return Nothing firstReadableOf (x:y) = do- isReadable <- fileAccess x True False False+ isThere <- fileExist x+ isReadable <- case isThere of+ False -> return False+ True -> fileAccess x True False False isReadable ? return (Just x) ?? firstReadableOf y - withIPC :: (MonadBaseControl IO m) => CliOptions -> (IPC -> m a) -> m a withIPC options f = restoreM =<< (liftBaseWith $ \runInIO -> do ZMQ.withContext $ \c -> do@@ -138,7 +151,7 @@ bindTitleChanged =<< Gui.readGUI Gui.webView -- Default web settings- WS.set webSettingsMonospaceFontFamily "consolas"+ WS.set webSettingsMonospaceFontFamily "inconsolata" WS.set webSettingsEnableDeveloperExtras True WS.set webSettingsEnableHtml5Database False WS.set webSettingsEnableHtml5LocalStorage False@@ -221,17 +234,19 @@ return webView' -bindDownload :: (MonadBase IO m, MonadBaseControl IO m, ConfigReader m m, MonadError HError m) => WebView -> m ()+bindDownload :: (MonadBase IO m, MonadBaseControl IO m, ConfigReader m m, NotificationReader m, MonadError HError m) => WebView -> m () bindDownload webView = do void . liftBaseWith $ \runInIO -> on webView W.downloadRequested $ \d -> do amount <- W.downloadGetTotalSize d - --notify 5000 $ "Requested download: " ++ filename ++ " (" ++ show size ++ ")" void . runInIO $ do uri <- downloadGetUri d filename <- downloadGetSuggestedFilename d callback <- readConfig onDownload- logV $ "Requested download <" ++ show uri ++ ">"++ logV $ "Requested download <" ++ show uri ++ ">"+ notify 5000 $ "Requested download: " ++ filename ++ " (" ++ show amount ++ ")"+ callback uri filename amount return False @@ -327,7 +342,7 @@ case (Key.lookup allStrokes =<< M.lookup theMode theBindings) of Just (Key.Leaf callback) -> Key.writeStatus Key.strokes [] >> callback `catchError` \e -> (io $ print e) >> notify 5000 (show e) Just (Key.Branch _) -> Key.writeStatus Key.strokes allStrokes- _ -> return () --}+ _ -> return () return () _ -> return () return False
Hbro/Config.hs view
@@ -19,7 +19,6 @@ import qualified Data.Map as M import Graphics.UI.Gtk.Gdk.EventM-import Graphics.UI.Gtk.WebKit.WebNavigationAction import Network.URI as N hiding(parseURI, parseURIReference) @@ -51,8 +50,9 @@ makeLenses ''Config instance Show (Config m) where- show c = "Home page = " ++ (show $ c^.homePage)- ++ "\nVerbosity = " ++ (show $ c^.verbosity)+ show c = unlines [+ "Home page = " ++ (show $ c^.homePage),+ "Verbosity = " ++ (show $ c^.verbosity)] -- | 'MonadReader' for 'Config'@@ -72,17 +72,6 @@ modifyConfig :: (ConfigState n m) => Simple Lens (Config n) a -> (a -> a) -> m () modifyConfig l f = writeConfig l . f =<< readConfig l--instance Eq NavigationReason where- a == b = (fromEnum a) == (fromEnum b)--instance Show NavigationReason where- show WebNavigationReasonLinkClicked = "Link clicked"- show WebNavigationReasonFormSubmitted = "Form submitted"- show WebNavigationReasonBackForward = "Back/forward"- show WebNavigationReasonReload = "Reload"- show WebNavigationReasonFormResubmitted = "Form resubmitted"- show WebNavigationReasonOther = "Other" -- }}} -- | Run an action unless verbosity is 'Quiet'
Hbro/Core.hs view
@@ -33,6 +33,7 @@ -- import Data.Foldable -- import Data.Functor import Data.IORef+import Data.Maybe import qualified Data.Map as M import Graphics.UI.Gtk.Gdk.EventM@@ -107,7 +108,7 @@ -- {{{ Default configuration instance Default (Config K) where def = Config {- _homePage = maybe undefined id . N.parseURI $ "https://duckduckgo.com/",+ _homePage = fromJust . N.parseURI $ "https://duckduckgo.com/", _verbosity = Normal, _keyBindings = defaultKeyBindings, _commands = def,
Hbro/Dyre.hs view
@@ -1,8 +1,11 @@ -- | Dynamic reconfiguration. Designed to be imported as @qualified@.-module Hbro.Dyre where+module Hbro.Dyre (+ wrap,+ recompile+) where -- {{{ Imports-import Hbro.Options+import Hbro.Options hiding(recompile) import Hbro.Util import Config.Dyre@@ -17,20 +20,23 @@ -- }}} --- | Print various paths used for dynamic reconfiguration+nullMain :: a -> IO ()+nullMain = const $ return ()++-- Print various paths used for dynamic reconfiguration printPaths :: MonadBase IO m => m () printPaths = io $ do- (a, b, c, d, e) <- getPaths (parameters $ const $ return ())+ (a, b, c, d, e) <- getPaths $ parameters nullMain False putStrLn $ unlines [ "Current binary: " ++ a, "Custom binary: " ++ b, "Config file: " ++ c, "Cache directory: " ++ d,- "Lib directory: " ++ e, []]+ "Lib directory: " ++ e] --- | Dynamic reconfiguration settings-parameters :: (a -> IO ()) -> Params (Either String a)-parameters main = defaultParams {+-- Dynamic reconfiguration settings+parameters :: (a -> IO ()) -> Bool -> Params (Either String a)+parameters main verbose' = defaultParams { projectName = "hbro", showError = const Left, realMain = main',@@ -39,16 +45,17 @@ includeCurrentDirectory = False} where main' (Left e) = putStrLn e- main' (Right x) = main x+ main' (Right x) = do+ when verbose' printPaths+ main x wrap :: (a -> IO ()) -> CliOptions -> a -> IO () wrap main opts args = do- when (opts^.verbose) printPaths- wrapMain ((parameters main) { configCheck = not $ opts^.vanilla }) $ Right args+ wrapMain ((parameters main (opts^.verbose)) { configCheck = not $ opts^.vanilla }) $ Right args -- | Launch a recompilation of the configuration file recompile :: IO (Maybe String) recompile = do- customCompile (parameters $ const $ return ())- getErrorString (parameters $ const $ return ())+ customCompile $ parameters nullMain False+ getErrorString $ parameters nullMain False
Hbro/Gui.hs view
@@ -124,7 +124,7 @@ build b = io $ NotificationBar <$> builderGetObject b castToLabel "notificationLabel" <*> newIORef Nothing instance (Monad m) => Buildable (GUI m) where- build b = io $ do+ build b = do (webView', sWindow') <- build b (window', wBox') <- build b promptBar' <- build b@@ -137,7 +137,7 @@ -- {{{ Util--- | Return the casted GObject corresponding to the given name (set in the builder's XML file)+-- | Return the casted 'GObject' corresponding to the given name (set in the builder's XML file) getObject :: (MonadBase IO m, GUIReader n m, GObjectClass a) => (GObject -> a) -> String -> m a getObject cast name = do b <- readGUI builder@@ -168,10 +168,10 @@ Prompt.init =<< readGUI promptBar WebView.init w - io $ windowSetDefault mw (Just w)+ io . windowSetDefault mw $ Just w -- Validate/cancel prompt- e <- readGUI (promptBar.(Prompt.entry))+ e <- readGUI $ promptBar.(Prompt.entry) io . void $ on e keyPressEvent (f w) -- Show window@@ -195,7 +195,7 @@ initWindow :: (MonadBase IO m) => Window -> m () initWindow window = io $ do- windowSetDefaultSize window 800 600+ windowSetDefaultSize window 1024 768 widgetModifyBg window StateNormal (Color 0 0 10000) void $ onDestroy window GTK.mainQuit
Hbro/Options.hs view
@@ -7,6 +7,7 @@ socketPath, help, quiet,+ uIFile, verbose, version, vanilla,@@ -17,8 +18,7 @@ usage, get, getStartURI,- getSocketURI,- getUIFile)+ getSocketURI) where -- {{{ Imports@@ -41,7 +41,6 @@ import System.Console.GetOpt import System.Directory import System.Environment-import System.Environment.XDG.BaseDir import System.FilePath import System.Posix.Process -- }}}@@ -155,9 +154,3 @@ dir <- io getTemporaryDirectory pid <- io getProcessID return $ "ipc://" ++ dir </> "hbro." ++ show pid---- | Return UI descriptor (XML file) used to build the GUI-getUIFile :: (MonadBase IO m, OptionsReader m) => m FilePath-getUIFile = maybe getDefaultUIFile return =<< readOptions uIFile- where- getDefaultUIFile = io (getUserConfigDir "hbro" >/> "ui.xml")
Hbro/Prompt.hs view
@@ -92,7 +92,6 @@ void . onEntryChanged entry' $ \v -> io (readIORef onChanged') >>= \f -> f v void . onEntryValidated entry' $ \v -> io (readIORef onValidated') >>= \f -> f v- return () where l = _description promptBar entry' = _entry promptBar
Hbro/Webkit/WebView.hs view
@@ -5,7 +5,6 @@ -- {{{ Imports import Hbro.Error import Hbro.Network---import Hbro.Types import Hbro.Util import Control.Monad.Base
README.rst view
@@ -53,9 +53,41 @@ Configuration ------------- -By default, a minimal 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 well-commented example of configuration file.+By default, a minimal 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 commented configuration file example. +GUI layout+----------++The graphical layout is described in an XML file that is parsed by GtkBuilder_ to build up the whole GUI. This file is looked for in several places with the following order of priority:++- the value from commandline option ``-u``;+- the file ``~/.config/hbro.ui.xml``;+- the file ``examples/ui.xml`` bundled with the package.++You must at least define the following widgets with the adequate ``id`` attribute:+++-----------------------+-----------------------++| Type | ``id`` |++=======================+=======================++| ``GtkWindow`` | ``mainWindow`` |++-----------------------+-----------------------++| ``GtkVBox`` | ``windowBox`` |++-----------------------+-----------------------++| ``GtkScrolledWindow`` | ``webViewParent`` |++-----------------------+-----------------------++| ``GtkHBox`` | ``promptBox`` |++-----------------------+-----------------------++| ``GtkLabel`` | ``promptDescription`` |++-----------------------+-----------------------++| ``GtkEntry`` | ``promptEntry`` |++-----------------------+-----------------------++| ``GtkHBox`` | ``statusBox`` |++-----------------------+-----------------------++| ``GtkLabel`` | ``notificationLabel`` |++-----------------------+-----------------------+++ Known bugs and limitations -------------------------- @@ -86,3 +118,4 @@ .. _ZeroMQ: http://www.zeromq.org/ .. _Dyre: https://github.com/willdonnelly/dyre .. _hbro-contrib: http://hackage.haskell.org/package/hbro-contrib+.. _GtkBuilder: https://developer.gnome.org/gtk3/stable/GtkBuilder.html
examples/ui.xml view
@@ -8,14 +8,14 @@ <child> <object class="GtkScrolledWindow" id="webViewParent"></object> </child>- + <!-- Prompt bar --> <child> <object class="GtkHBox" id="promptBox"> <property name="homogeneous">False</property> <property name="spacing">10</property>- + <child> <object class="GtkLabel" id="promptDescription"></object> <packing>@@ -39,7 +39,7 @@ <object class="GtkHBox" id="statusBox"> <property name="homogeneous">False</property> <property name="spacing">5</property>- + <child> <object class="GtkLabel" id="void"></object> <packing>@@ -61,7 +61,7 @@ <object class="GtkHBox" id="notificationBox"> <property name="homogeneous">False</property> <property name="spacing">5</property>- + <child> <object class="GtkLabel" id="notificationLabel"> <property name="single-line-mode">True</property>
hbro.cabal view
@@ -1,5 +1,5 @@ Name: hbro-Version: 1.1.2.0+Version: 1.1.2.1 Synopsis: Minimal KISS compliant browser -- Description: Homepage: http://projects.haskell.org/hbro/@@ -17,11 +17,11 @@ Data-files: examples/ui.xml Source-repository head- Type: git- Location: git@github.com:k0ral/hbro.git+ Type: hg+ Location: https://bitbucket.org/k0ral/hbro Source-repository head- Type: git- Location: git@twyk.org/haskell-browser.git+ Type: hg+ Location: https://hgweb.twyk.org/hbro Library Build-depends: