hbro 0.7.0.1 → 0.7.1.0
raw patch · 10 files changed
+441/−223 lines, 10 filesdep +xdg-basedir
Dependencies added: xdg-basedir
Files
- Hbro/Core.hs +55/−56
- Hbro/Extra/History.hs +14/−5
- Hbro/Extra/StatusBar.hs +26/−24
- Hbro/Keys.hs +93/−0
- Hbro/Main.hs +3/−7
- Hbro/Types.hs +40/−16
- Hbro/Util.hs +19/−62
- README.rst +118/−0
- examples/hbro.hs +58/−49
- hbro.cabal +15/−4
Hbro/Core.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DoRec #-} module Hbro.Core ( -- * Main defaultConfig,@@ -18,9 +19,10 @@ -- {{{ Imports import Hbro.Gui+--import Hbro.Keys import Hbro.Socket import Hbro.Types-import Hbro.Util+--import Hbro.Util import qualified Config.Dyre as D import Config.Dyre.Paths@@ -28,12 +30,10 @@ import Control.Concurrent import Control.Monad.Reader -import qualified Data.Map as Map-import qualified Data.Set as Set+import qualified Data.Map as M -import Graphics.UI.Gtk.Abstract.Widget+--import Graphics.UI.Gtk.Abstract.Widget import Graphics.UI.Gtk.General.General hiding(initGUI)-import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.Misc.Adjustment import Graphics.UI.Gtk.Scrolling.ScrolledWindow import Graphics.UI.Gtk.WebKit.WebDataSource@@ -44,7 +44,8 @@ import System.Console.CmdArgs import System.Directory-import System.Glib.Signals+import System.Environment.XDG.BaseDir+--import System.Glib.Signals import System.IO import System.Posix.Process import System.Posix.Signals@@ -54,12 +55,17 @@ -- {{{ Commandline options cliOptions :: CliOptions cliOptions = CliOptions {- mURI = def &= help "URI to open at start-up" &= explicit &= name "u" &= name "uri" &= typ "URI"+ 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"] []+ &= verbosityArgs [explicit, name "verbose", name "v"] [] &= versionArg [ignore] &= help "A minimal KISS-compliant browser." &= helpArg [explicit, name "help", name "h"]@@ -67,7 +73,7 @@ -- }}} -- {{{ Configuration (Dyre)-dyreParameters :: D.Params Config+dyreParameters :: D.Params (Config, CliOptions) dyreParameters = D.defaultParams { D.projectName = "hbro", D.showError = showError,@@ -76,22 +82,22 @@ D.statusOut = hPutStrLn stderr } -showError :: Config -> String -> Config-showError config message = config { mError = Just message }+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 :: FilePath -> FilePath -> Config -defaultConfig home tmp = Config {- mHomePage = "https://encrypted.google.com/",- mSocketDir = tmp,- mUIFile = home ++ "/.config/hbro/ui.xml",- mKeys = const [],- mWebSettings = [],- mSetup = const (return () :: IO ()),- mCommands = [],- mError = Nothing+defaultConfig :: CommonDirectories -> Config+defaultConfig directories = Config {+ mCommonDirectories = directories,+ mHomePage = "https://encrypted.google.com/",+ mSocketDir = mTemporary directories,+ mUIFile = (mConfiguration directories) ++ "/ui.xml",+ mWebSettings = [],+ mSetup = const (return () :: IO ()),+ mCommands = [],+ mError = Nothing } -- }}} @@ -99,19 +105,27 @@ -- | Browser's main function. -- To be called in main function with a proper configuration. -- See Hbro.Main for an example.-launchHbro :: Config -> IO ()-launchHbro = D.wrapMain dyreParameters+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 -> IO ()-realMain config = do+realMain :: (Config, CliOptions) -> IO ()+realMain (config, options) = do -- Print configuration error, if any maybe (return ()) putStrLn $ mError config --- Parse commandline arguments- options <- getOptions- -- Print in-use paths- getPaths dyreParameters >>= \(a,b,c,d,e) -> whenLoud $ do + whenLoud $ getPaths dyreParameters >>= \(a,b,c,d,e) -> do putStrLn ("Current binary: " ++ a) putStrLn ("Custom binary: " ++ b) putStrLn ("Config file: " ++ c)@@ -127,33 +141,18 @@ realMain' :: Config -> CliOptions -> GUI -> ZMQ.Context -> IO () realMain' config options gui@GUI {mWebView = webView, mWindow = window} context = let- environment = Environment options config gui context- keys = importKeyBindings $ (mKeys config) environment- setup = mSetup config- socketDir = mSocketDir config - commands = mCommands config+ 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---- Manage keys- _ <- after webView keyPressEvent $ do- value <- eventKeyVal- modifiers <- eventModifier-- let keyString = keyToString value-- case keyString of - Just "<Escape>" -> liftIO $ widgetHide ((mBox . mPromptBar) gui)- Just string -> do - case Map.lookup (Set.fromList modifiers, string) keys of- Just callback -> do- liftIO $ callback- liftIO $ whenLoud (putStrLn $ "Key pressed: " ++ show modifiers ++ string ++ " (mapped)")- _ -> liftIO $ whenLoud (putStrLn $ "Key pressed: " ++ show modifiers ++ string ++ " (unmapped)")- _ -> return ()-- return False+ +-- Setup key handler+ --rec i <- after webView keyPressEvent $ keyEventHandler keyEventCallback i webView -- Load homepage case (mURI options) of@@ -168,8 +167,8 @@ -- Open socket pid <- getProcessID- let commandsList = Map.fromList $ defaultCommandsList ++ commands- let socketURI = "ipc://" ++ socketDir ++ "/hbro." ++ show pid+ let commandsList = M.fromList $ defaultCommandsList ++ commands+ let socketURI = "ipc://" ++ socketDir ++ "/hbro." ++ show pid void $ forkIO (openRepSocket context socketURI (listenToCommands environment commandsList)) -- Manage POSIX signals@@ -243,7 +242,7 @@ adjustmentSetValue adjustment upper -- }}}-+ -- {{{ Misc -- | Wrapper around webFramePrint function, provided for convenience. printPage :: WebView -> IO ()
Hbro/Extra/History.hs view
@@ -12,19 +12,28 @@ import qualified Data.Text.IO as T import Data.Time +--import System.IO.Error import System.Locale -- }}} --- |-add :: FilePath -> String -> String -> IO ()+-- | 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- appendFile historyFile $ time ++ " " ++ uri ++ " " ++ title ++ "\n"+ let newLine = time ++ " " ++ uri ++ " " ++ title ++ "\n"+ _ <- catch (appendFile historyFile newLine) (\_ -> putStrLn $ "[WARNING] You need to create history file" ++ historyFile)+ return ()+ --- |-select :: FilePath -> [String] -> IO (Maybe String)+-- | 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
Hbro/Extra/StatusBar.hs view
@@ -1,19 +1,19 @@ module Hbro.Extra.StatusBar where -- {{{ Imports---import Hbro.Types-import Hbro.Util +--import Hbro.Keys+import Hbro.Types+--import Hbro.Util -import Control.Monad.Trans(liftIO)+--import Control.Monad.Trans(liftIO) import Data.List import Graphics.Rendering.Pango.Enums import Graphics.Rendering.Pango.Layout -import Graphics.UI.Gtk.Abstract.Widget import Graphics.UI.Gtk.Display.Label-import Graphics.UI.Gtk.Gdk.EventM+--import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.Misc.Adjustment import Graphics.UI.Gtk.Scrolling.ScrolledWindow import Graphics.UI.Gtk.WebKit.WebView@@ -53,29 +53,31 @@ zoomLevel <- webViewGetZoomLevel webView labelSetMarkup widget $ "<span foreground=\"white\">x" ++ escapeMarkup (show zoomLevel) ++ "</span>"-+ --- | Display pressed keys in status bar.--- Needs a Label entitled "keys" from the builder.-statusBarPressedKeys :: Label -> WebView -> IO ()-statusBarPressedKeys widget webView = do+-- | +withFeedback :: Label -> WebView -> KeyEventCallback -> KeyEventCallback+withFeedback widget webView 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 0 65535 0}+ AttrForeground {paStart = 0, paEnd = -1, paColor = color} ] - _ <- after webView keyPressEvent $ do- value <- eventKeyVal- modifiers <- eventModifier-- let keyString = keyToString value- case (keyString, modifiers) of - (Just k, []) -> liftIO $ labelSetText widget k- (Just k, m) -> liftIO $ labelSetText widget (show m ++ k)- _ -> return ()-- return False- return ()-+-- 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 ()
+ Hbro/Keys.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE DoRec #-}+module Hbro.Keys where++-- {{{ Imports+import Hbro.Types++--import Control.Monad+import Control.Monad.Trans++import qualified Data.Map as M+import qualified Data.Set as S++import Graphics.UI.Gtk.Abstract.Widget+import Graphics.UI.Gtk.Gdk.EventM+import Graphics.UI.Gtk.Gdk.Keys+import Graphics.UI.Gtk.WebKit.WebView++import System.Console.CmdArgs (whenLoud, whenNormal)+import System.Glib.Signals+-- }}}++instance Ord Modifier where+ m <= m' = fromEnum m <= fromEnum m'++-- | Retrieve modifiers and pressed keys, and forward them to a handler.+withKeys :: ([Modifier] -> String -> IO ()) -> EventM EKey Bool+withKeys handler = do+ value <- eventKeyVal+ modifiers <- eventModifier++ liftIO $ maybe (return ()) (\string -> handler modifiers string) (keyToString value)++ return False++-- | Look for a callback associated to the given modifiers and pressed keys and trigger it, if any.+simpleKeyEventCallback :: KeysMap -> KeyEventCallback+simpleKeyEventCallback keysMap modifiers keys = do+ whenLoud $ putStr ("Key pressed: " ++ show modifiers ++ keys ++ " ")+ + case M.lookup (S.fromList modifiers, keys) keysMap of+ Just callback -> callback >> (whenLoud $ putStrLn "(mapped)") >> return True+ _ -> (whenLoud $ putStrLn "(unmapped)") >> return False++-- | Basic key handler which doesn't support sequential keystrokes.+simpleKeyEventHandler :: KeyEventCallback -> ConnectId WebView -> WebView -> EventM EKey Bool+simpleKeyEventHandler callback _ _ = withKeys (\x y -> callback x y >> return ())++-- | Key handler with sequential keystrokes support.+advancedKeyEventHandler :: KeyEventCallback -> ConnectId WebView -> WebView -> EventM EKey Bool+advancedKeyEventHandler = advancedKeyEventHandler' []+ +advancedKeyEventHandler' :: String -> KeyEventCallback -> ConnectId WebView -> WebView -> EventM EKey Bool+advancedKeyEventHandler' previousKeys callback oldID webView = withKeys $ \modifiers newKey -> do+ let keys = previousKeys ++ newKey+ let newHandler = \x -> do+ rec newID <- after webView keyPressEvent $ advancedKeyEventHandler' x callback newID webView+ return ()+ + signalDisconnect oldID+ result <- callback modifiers keys+ case result of+ True -> newHandler []+ _ -> case newKey of+ "<Escape>" -> newHandler []+ _ -> newHandler keys++-- | Convert a keyVal to a String.+-- For printable characters, the corresponding String is returned, except for the space character for which "<Space>" is returned.+-- For non-printable characters, the corresponding keyName wrapped into "< >" is returned.+-- For modifiers, Nothing is returned.+keyToString :: KeyVal -> Maybe String+keyToString keyVal = case keyToChar keyVal of+ Just ' ' -> Just "<Space>"+ Just char -> Just [char]+ _ -> case keyName keyVal of+ "Caps_Lock" -> Nothing+ "Shift_L" -> Nothing+ "Shift_R" -> Nothing+ "Control_L" -> Nothing+ "Control_R" -> Nothing+ "Alt_L" -> Nothing+ "Alt_R" -> Nothing+ "Super_L" -> Nothing+ "Super_R" -> Nothing+ "Menu" -> Nothing+ "ISO_Level3_Shift" -> Nothing+ "dead_circumflex" -> Just "^"+ "dead_diaeresis" -> Just "¨"+ x -> Just ('<':x ++ ">")++-- | Convert key bindings list to a map.+keysListToMap :: KeysList -> KeysMap+keysListToMap = M.fromList . (map (\((a,b),c) -> ((S.fromList a, b), c)))
Hbro/Main.hs view
@@ -5,20 +5,16 @@ import Hbro.Types import Paths_hbro--import System.Directory -- }}} -- | Default main function provided as example. main :: IO () main = do- home <- getHomeDirectory- tmp <- getTemporaryDirectory- uiFile <- getDataFileName "examples/ui.xml"- -- putStrLn "[WARNING] You are running the default configuration which provides hardly no feature." -- putStrLn "[WARNING] You should copy the example configuration files hbro.hs and ui.xml in ~/.config/hbro/hbro and start hacking them." - launchHbro $ (defaultConfig home tmp) {+ uiFile <- getDataFileName "examples/ui.xml"+ + launchHbro $ \d -> (defaultConfig d) { mUIFile = uiFile }
Hbro/Types.hs view
@@ -4,6 +4,7 @@ -- {{{ Imports import Data.Map+import Data.Set import Graphics.UI.Gtk.Builder import Graphics.UI.Gtk.Display.Label@@ -17,32 +18,50 @@ import System.Console.CmdArgs import System.Glib.Attributes+--import System.Glib.Signals import System.ZMQ -- }}} +-- | Various directories used to store some runtime and static files.+data CommonDirectories = CommonDirectories {+ mHome :: FilePath, -- ^ Home directory+ mTemporary :: FilePath, -- ^ Temporary files directory+ mConfiguration :: FilePath, -- ^ Configuration directory+ mData :: FilePath -- ^ Data directory+}+ +-- | The whole set of parameters and elements of the browser. data Environment = Environment { mOptions :: CliOptions, -- ^ Commandline options mConfig :: Config, -- ^ Configuration parameters (constants) provided by user mGUI :: GUI, -- ^ Graphical widgets- mContext :: Context -- ^ + mContext :: Context -- ^ ZMQ context } +-- | Supported commandline options data CliOptions = CliOptions {- mURI :: Maybe String -- ^ URI to load at start-up+ mURI :: Maybe String, -- ^ URI to load at start-up+ mVanilla :: Bool, -- ^ Bypass custom configuration file+ mDenyReconf :: Bool, -- ^ Do not recompile browser even if configuration file has changed+ mForceReconf :: Bool, -- ^ Force recompilation even if configuration file hasn't changed+ mDyreDebug :: Bool, -- ^ Look for a custom configuration file in working directory+ mMasterBinary :: Maybe String -- ^ } deriving (Data, Typeable, Show, Eq) data Config = {-forall a.-} Config {- mHomePage :: String, -- ^ Startup page - mSocketDir :: String, -- ^ Directory where 0MQ will be created ("/tmp" for example)- mUIFile :: String, -- ^ Path to XML file describing UI (used by GtkBuilder)- mKeys :: Environment -> KeysList, -- ^ List of keybindings- 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- --mCustom :: a+ 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+ --mCustom :: a } data GUI = GUI {@@ -62,14 +81,19 @@ } --- | List of bound keys--- All callbacks are fed with the Browser instance+-- | List of bound keys.+-- All callbacks are fed with the Browser instance.+-- -- Note 1 : for modifiers, lists are used for convenience purposes, -- but are transformed into sets in hbro's internal machinery,--- so that order and repetition don't matter+-- so that order and repetition don't matter.+-- -- Note 2 : for printable characters accessed via the shift modifier,--- you do have to include Shift in modifiers list-type KeysList = [(([Modifier], String), IO ())]+-- you do have to include Shift in modifiers list.+type KeysList = [(([Modifier], String), IO ())]+type KeysMap = Map (Set Modifier, String) (IO ())+type KeyEventCallback = [Modifier] -> String -> IO Bool+--data KeyMode = CommandMode | InsertMode type CommandsList = [(String, ([String] -> Socket Rep -> Environment -> IO ()))] type CommandsMap = Map String ([String] -> Socket Rep -> Environment -> IO ())
Hbro/Util.hs view
@@ -1,23 +1,26 @@-module Hbro.Util where+module Hbro.Util (+-- * Process management+ runCommand',+ spawn,+ getAllProcessIDs,+-- * Misc+ labelSetMarkupTemporary,+ dmenu+) where -- {{{ Imports-import Hbro.Types+--import Hbro.Types --import Control.Monad.Reader import Control.Monad import Data.List-import qualified Data.Map as Map-import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.IO as T 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 qualified System.Info as Sys import System.IO import System.Posix.Process@@ -25,50 +28,7 @@ -- }}} -instance Ord Modifier where- m <= m' = fromEnum m <= fromEnum m'----- {{{ Keys-related functions--- | Converts a keyVal to a String.--- For printable characters, the corresponding String is returned, except for the space character for which "<Space>" is returned.--- For non-printable characters, the corresponding keyName between <> is returned.--- For modifiers, Nothing is returned.-keyToString :: KeyVal -> Maybe String-keyToString keyVal = case keyToChar keyVal of- Just ' ' -> Just "<Space>"- Just char -> Just [char]- _ -> case keyName keyVal of- "Caps_Lock" -> Nothing- "Shift_L" -> Nothing- "Shift_R" -> Nothing- "Control_L" -> Nothing- "Control_R" -> Nothing- "Alt_L" -> Nothing- "Alt_R" -> Nothing- "Super_L" -> Nothing- "Super_R" -> Nothing- "Menu" -> Nothing- "ISO_Level3_Shift" -> Nothing- "dead_circumflex" -> Just "^"- "dead_diaeresis" -> Just "¨"- x -> Just ('<':x ++ ">")---- | Convert key bindings list to a map.--- Calls importKeyBindings'.-importKeyBindings :: KeysList -> Map.Map (Set.Set Modifier, String) (IO ())-importKeyBindings list = Map.fromList $ importKeyBindings' list---- | Convert modifiers list to modifiers sets.--- The order of modifiers in key bindings don't matter.--- Called by importKeyBindings.-importKeyBindings' :: KeysList -> [((Set.Set Modifier, String), IO ())]-importKeyBindings' (((a, b), c):t) = ((Set.fromList a, b), c):(importKeyBindings' t)-importKeyBindings' _ = []--- }}}----- {{{ Run commands+-- {{{ Process management -- | Like run `runCommand`, but return IO () runCommand' :: String -> IO () runCommand' command = runCommand command >> return ()@@ -82,6 +42,14 @@ 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 ()++getAllProcessIDs :: IO [FilePath]+getAllProcessIDs = do + (_, pids, _) <- readProcessWithExitCode "pidof" ["hbro"] []+ (_, pids', _) <- readProcessWithExitCode "pidof" ["hbro-" ++ Sys.os ++ "-" ++ Sys.arch] []+ myPid <- getProcessID++ return $ delete (show myPid) . nub . words $ pids ++ " " ++ pids' -- }}} -- | Set a temporary markup text to a label that disappears after some delay.@@ -91,17 +59,6 @@ timeoutAdd clear delay where clear = labelSetMarkup label "" >> return False---getAllProcessIDs :: IO [FilePath]-getAllProcessIDs = do - (_, pids, _) <- readProcessWithExitCode "pidof" ["hbro"] []- (_, pids', _) <- readProcessWithExitCode "pidof" ["hbro-" ++ Sys.os ++ "-" ++ Sys.arch] []- myPid <- getProcessID-- return $ delete (show myPid) . nub . words $ pids ++ " " ++ pids'- - (>>?) :: (a -> IO ()) -> Maybe a -> IO ()
+ README.rst view
@@ -0,0 +1,118 @@+====+hbro+====+++**In a nutshell**: *hbro* is a minimal KISS compliant browser written in Haskell and for linux, still in development but pretty usable.++Informations about versions, dependencies, source repositories and contacts can be found in hackage_.+++Design principles+-----------------++Do only one thing...+ Modern browsers include many features that could be easily externalized ; actually, life would even be easier if those features were independent and shared with all desktop applications. Such features are for instance tabs, bookmarks, history, downloads, adblocking, passwords saving, self-updating. A UNIX-compliant browser should just be flexible enough to call external tools for such jobs.++... but do it well+ Browsing well first implies making our way through the mess of web standards that are growing harder and sloppier; sometimes it means breaking some other golden rules, but there's no choice.++Keep It Simple, Stupid+ Simplicity is not only compatible with but also essential to a powerful application. It often comes together with lightweight, scalable and easy-to-hack qualities.++Robustness & stability+ Let's spend our time in developing new features rather than in tracking rare bugs. Let's go slow but sure.++Extensibility and programmable interface+ Targets are advanced users who have various expectations ; to be sure everyone is happy, configuration should use a programming language, and an interprocess interface should be available. As he who can do the most can do the least, the default configuration should be suitable for users that cannot afford/don't want to spend (waste ?) their time in tweaks.++Keyboard-friendly+ Special attention should be given to allow keyboard control of the browser whenever possible ; however, this should not become an obsession in cases where mouse use is obviously a more convenient solution (yes, such cases do exist).++Free software+ Hbro is distributed under the `Do-What-The-Fuck-You-Want-To public licence`_, which has a pretty self-explanatory name :) .++Note that some of these principles are taken from the `suckless manifest`_.+++Components and libraries used+-----------------------------++Programming language : Haskell_+ Modern, purely-functional language that makes it possible to work with a short, elegant and robust code.++Layout engine : WebKit_+ Webkit seems to be the only one being open-source, (kind of) standards-compliant and providing a Haskell binding. It's then not much of a choice, fortunately it's not that bad.++UI toolkit : `GTK+`_+ Given the above programming language and layout engine, there's no much choice left for the UI toolkit.++Interprocess interface : ZeroMQ_+ Socket-like interface that implements various convenient communication schemes like request-reply and publish-subscribe.++Configuration system : Dyre_+ Dynamic reconfiguration library for haskell programs.+++Apart from the programming language, if you happen to find a better alternative for one of these points, please note that suggestions are more than welcome :) .+++.. How to install it ?+ -------------------+ + Please note that despite being written in a multiplatform language, *hbro* will only run under a linux environment.+ + The simplest way is using the haskell packaging system::+ + cabal install hbro+ + Alternatively, you can download the hbro package from hackage, and install it with cabal-install.+++.. Where to get the source ?+ -------------------------+ + The latest source is hosted:+ + * on github: ``git@github.com:k0ral/hbro.git``+ * on a personal server, which is unfortunately shutdown every european night: ``git://twyk.org/haskell-browser.git``+ + You can still retrieve the source from hackage at any time, however the very last commits may not be included.+++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``.+++Known bugs and limitations+--------------------------++Patches or suggestions are welcome to deal with the following issues. See package description for contact address.++Flash videos make hbro freeze+ The demo webkit browser for haskell's binding has the same problem, so it doesn't seem to come from hbro itself.++Javascript's window.open requests open in the same window instead of spawning a new one.+ This is due to this webkit's bug.++When toggling to source mode, current webpage is reloaded+ This is an undesired behavior since the webpage may have changed after reloading; webkit's API allows to get the content of the DOM but only inside the body tag; it is also possible to store the HTML source as it is downloaded, but then any further change in the DOM (for example triggered by javascript functions) wouldn't be visible.++No cookies management available+ The Haskell binding is missing some necessary functions that make it impossible to act on cookies management.++Configuring a proxy is impossible+ This feature would make use of to the webkit_get_default_session_ function. Unfortunately, Webkit's Haskell binding doesn't provide such function for now.+++.. _hackage: http://hackage.haskell.org/package/hbro+.. _suckless manifest: http://suckless.org/manifest/+.. _Do-What-The-Fuck-You-Want-To public licence: http://en.wikipedia.org/wiki/WTFPL+.. _Haskell: http://haskell.org/+.. _WebKit: http://www.webkit.org/+.. _GTK+: http://www.gtk.org/+.. _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
examples/hbro.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DoRec #-} module Main where -- {{{ Imports@@ -10,6 +11,7 @@ import Hbro.Extra.Session import Hbro.Extra.StatusBar import Hbro.Gui+import Hbro.Keys import Hbro.Socket import Hbro.Types import Hbro.Util@@ -31,53 +33,64 @@ 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, basically launches hbro.+-- Main function, expected to call launchHbro.+-- You can add custom tasks before & after calling it. main :: IO ()-main = do- home <- getHomeDirectory- tmp <- getTemporaryDirectory- launchHbro $ myConfig home tmp-+main = launchHbro myConfig --- | Application parameters.--- See Hbro.Types.Parameters documentation for fields description.--- Commented out fields indicate default values.-myConfig :: String -> String -> Config-myConfig home tmp = (defaultConfig home tmp) {- --mSocketDir = tmp,- mUIFile = home ++ "/.config/hbro/ui.xml",- mHomePage = "https://duckduckgo.com",- mKeys = myKeys home,+-- 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,+ mUIFile = myUIFile directories,+ mHomePage = myHomePage, mWebSettings = myWebSettings, mSetup = mySetup } +-- Various constant parameters+myHomePage = "https://duckduckgo.com" -myHistoryFile :: FilePath -> FilePath-myHistoryFile home = home ++ "/.config/hbro/history"+mySocketDirectory :: CommonDirectories -> FilePath+mySocketDirectory directories = mTemporary directories -myBookmarksFile :: FilePath -> FilePath-myBookmarksFile home = home ++ "/.config/hbro/bookmarks"+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]+ + -- {{{ Keys -- Note that this example is suited for an azerty keyboard.-myKeys :: FilePath -> Environment -> KeysList-myKeys home environment@Environment {mGUI = gui, mConfig = config, mContext = context} = let+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 home- historyFile = myHistoryFile home+ bookmarksFile = myBookmarksFile (mCommonDirectories config)+ historyFile = myHistoryFile (mCommonDirectories config) socketDir = mSocketDir config in [@@ -122,7 +135,8 @@ (([Control], "p"), withClipboard $ maybe (return ()) (loadURI webView)), (([Control, Shift], "P"), withClipboard $ maybe (return ()) (\uri -> spawn "hbro" ["-u", uri])), --- Others+-- Misc+ (([], "<Escape>"), widgetHide $ mBox promptBar), (([Control], "i"), showWebInspector webView), (([Alt], "p"), printPage webView), (([Control], "t"), spawn "hbro" []),@@ -148,10 +162,10 @@ -- }}} -- {{{ Web settings--- Commented lines correspond to default values+-- Commented out lines correspond to default values. myWebSettings :: [AttrOp WebSettings] myWebSettings = [- --SETTING DEFAULT VALUE +-- SETTING VALUE --webSettingsCursiveFontFamily := "serif", --webSettingsDefaultFontFamily := "sans-serif", --webSettingsFantasyFontFamily := ,@@ -196,49 +210,53 @@ -- {{{ Setup mySetup :: Environment -> IO ()-mySetup environment@Environment {mGUI = gui} = +mySetup environment@Environment{ mGUI = gui, mConfig = config } = let builder = mBuilder gui webView = mWebView gui scrolledWindow = mScrollWindow gui window = mWindow gui- in do + directories = mCommonDirectories config+ historyFile = myHistoryFile directories+ getLabel = builderGetObject builder castToLabel+ in do -- Scroll position in status bar- scrollLabel <- builderGetObject builder castToLabel "scroll"+ scrollLabel <- getLabel "scroll" setupScrollWidget scrollLabel scrolledWindow -- Zoom level in status bar- zoomLabel <- builderGetObject builder castToLabel "zoom"+ zoomLabel <- getLabel "zoom" statusBarZoomLevel zoomLabel webView- - -- Pressed keys in status bar- keysLabel <- builderGetObject builder castToLabel "keys"- statusBarPressedKeys keysLabel webView- + -- Load progress in status bar- progressLabel <- builderGetObject builder castToLabel "progress"+ progressLabel <- getLabel "progress" statusBarLoadProgress progressLabel webView -- Current URI in status bar- uriLabel <- builderGetObject builder castToLabel "uri"+ uriLabel <- getLabel "uri" statusBarURI uriLabel webView+ + -- Manage keystrokes+ keysLabel <- getLabel "keys"+ rec i <- after webView keyPressEvent $ advancedKeyEventHandler (withFeedback keysLabel webView (simpleKeyEventCallback $ keysListToMap (myKeys environment))) i 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- feedbackLabel <- builderGetObject builder castToLabel "feedback" case (uri, name) of (Just uri', Just name') -> do- myDownload uri' name' + 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@@ -252,12 +270,11 @@ _ -> webPolicyDecisionDownload policyDecision >> return True -- History handler- home <- getHomeDirectory _ <- on webView loadFinished $ \_ -> do uri <- webViewGetUri webView title <- webViewGetTitle webView case (uri, title) of- (Just uri', Just title') -> History.add (myHistoryFile home) uri' title'+ (Just uri', Just title') -> History.add historyFile uri' title' _ -> return () -- On navigating to a new URI@@ -293,11 +310,3 @@ return () -- }}}-- -myDownload :: String -> String -> IO ()-myDownload uri name = do- home <- getHomeDirectory- --spawn "wget [uri, "-O", home ++ "/" ++ name]- --spawn "axel [uri, "-o", home ++ "/" ++ name]- spawn "aria2c" [uri, "-d", home ++ "/", "-o", name]
hbro.cabal view
@@ -1,5 +1,5 @@ Name: hbro-Version: 0.7.0.1+Version: 0.7.1.0 Synopsis: A minimal KISS compliant browser -- Description: Homepage: http://projects.haskell.org/hbro/@@ -14,13 +14,17 @@ Cabal-version: >=1.8 Build-type: Simple-Extra-source-files: examples/hbro.hs+Extra-source-files: README.rst examples/hbro.hs Data-files: examples/ui.xml Source-repository head Type: git Location: git@twyk.org/haskell-browser.git +Source-repository head+ Type: git+ Location: git@github.com:k0ral/hbro.git+ Library Build-depends: base == 4.*,@@ -37,9 +41,10 @@ process, text, time,+ unix, url, webkit,- unix,+ xdg-basedir, zeromq-haskell Exposed-modules: Hbro.Core,@@ -51,11 +56,15 @@ Hbro.Extra.Session, Hbro.Extra.StatusBar, Hbro.Gui,+ Hbro.Keys, Hbro.Socket, Hbro.Types, Hbro.Util Ghc-options: -Wall +Flag threaded+ Description: Build with -threaded+ Default: True Executable hbro Build-depends: @@ -65,5 +74,7 @@ mtl Main-is: Main.hs Hs-Source-Dirs: Hbro - Ghc-options: -Wall -threaded + Ghc-options: -Wall+ if flag(threaded)+ Ghc-options: -threaded