diff --git a/Hbro/Boot.hs b/Hbro/Boot.hs --- a/Hbro/Boot.hs +++ b/Hbro/Boot.hs @@ -11,7 +11,7 @@ import qualified Hbro.IPC as IPC import qualified Hbro.Keys as Key import Hbro.Notification -import Hbro.Options (CliOptions) +import Hbro.Options (CliOptions, OptionsReader(..)) import qualified Hbro.Options as Options import Hbro.Util import qualified Hbro.Webkit.WebSettings as WS @@ -24,6 +24,7 @@ import Control.Monad import Control.Monad.Base import Control.Monad.Error hiding(when) +import Control.Monad.Reader hiding(when) import Control.Monad.Trans.Control import Data.Default @@ -46,13 +47,9 @@ import Prelude hiding(init) -import System.Directory -import System.Environment.XDG.BaseDir import System.Exit -import System.FilePath import System.Glib.Signals import System.Posix.Files -import System.Posix.Process import System.Posix.Signals import System.ZMQ3 (Rep(..)) import qualified System.ZMQ3 as ZMQ @@ -75,30 +72,30 @@ hbro' :: (K (), CliOptions) -> IO () hbro' (customSetup, options) = do - config <- initConfig options - gui <- initGUI - ipc <- initIPC - void $ installHandler sigINT (Catch onInterrupt) Nothing - (result, logs) <- runK options config gui ipc $ main customSetup + config <- runReaderT initConfig options + gui <- runReaderT initGUI options + + (result, logs) <- withIPC options $ \ipc -> runK options config gui ipc $ main customSetup + either print return result unless (options^.Options.quiet) . unless (null logs) $ putStrLn logs unless (options^.Options.quiet) $ putStrLn "Exiting..." -- {{{ Initialization -initConfig :: (MonadBase IO m) => CliOptions -> m (Config K) -initConfig options = do - let config = id +initConfig :: (MonadBase IO m, OptionsReader m) => m (Config K) +initConfig = do + options <- readOptions id + return $ id . (options^.Options.quiet ? set verbosity Quiet ?? id) . (options^.Options.verbose ? set verbosity Verbose ?? id) $ def - return config -initGUI :: (MonadBase IO m) => m (GUI K) +initGUI :: (MonadBase IO m, OptionsReader m) => m (GUI K) initGUI = do - file <- io (getUserConfigDir "hbro" >/> "ui.xml") + file <- Options.getUIFile fallback <- io $ getDataFileName "examples/ui.xml" file' <- io $ firstReadableOf [file, fallback] @@ -115,19 +112,12 @@ isReadable ? return (Just x) ?? firstReadableOf y -initIPC :: (MonadBase IO m) => m IPC -initIPC = io $ do - theContext <- ZMQ.init 1 - socket <- ZMQ.socket theContext Rep - ZMQ.bind socket =<< getSocketURI - return $ IPC theContext socket - - -getSocketURI :: (MonadBase IO m) => m String -getSocketURI = do - dir <- io getTemporaryDirectory - pid <- io getProcessID - return $ "ipc://" ++ dir "hbro." ++ show pid +withIPC :: (MonadBaseControl IO m) => CliOptions -> (IPC -> m a) -> m a +withIPC options f = restoreM =<< (liftBaseWith $ \runInIO -> do + ZMQ.withContext $ \c -> do + ZMQ.withSocket c Rep $ \s -> do + io . ZMQ.bind s =<< runReaderT Options.getSocketURI options + runInIO $ f (IPC c s)) -- }}} @@ -176,11 +166,8 @@ io GTK.mainGUI -- Clean & close - void . (`IPC.sendCommand` "QUIT") =<< getSocketURI + void . (`IPC.sendCommand` "QUIT") =<< Options.getSocketURI io $ takeMVar threadSync - - io . ZMQ.close =<< readIPC IPC.receiver - io . ZMQ.term =<< readIPC IPC.context -- | IPC thread that listens to commands from external world. diff --git a/Hbro/Core.hs b/Hbro/Core.hs --- a/Hbro/Core.hs +++ b/Hbro/Core.hs @@ -58,9 +58,6 @@ newtype K a = K { unKT :: ErrorT HError (WriterT String (ReaderT CliOptions (ReaderT (IORef (Config K)) (ReaderT (GUI K) (ReaderT IPC (ReaderT (IORef Keys.Status) IO)))))) a} deriving (Applicative, Functor, Monad, MonadBase IO, MonadError HError, MonadWriter String) -{-instance MonadBase IO K where - liftBase = K . lift . lift . lift . lift . lift . lift-} - instance MonadBaseControl IO K where newtype StM K a = StK { unStK :: StM (ErrorT HError (WriterT String (ReaderT CliOptions (ReaderT (IORef (Config K)) (ReaderT (GUI K) (ReaderT IPC (ReaderT (IORef Keys.Status) IO))))))) a } liftBaseWith f = K . liftBaseWith $ \runInBase -> f $ liftM StK . runInBase . unKT @@ -167,8 +164,8 @@ ("C-", scroll Vertical (Absolute 100)), ("M-", goHome), -- Copy/paste - ("C-c", getURI >>= Clipboard.insert . show), -- >> notify 5000 "URI copied to clipboard"), - ("M-c", getTitle >>= Clipboard.insert), -- >> notify 5000 "Page title copied to clipboard"), + ("C-c", getURI >>= Clipboard.insert . show >> notify 5000 "URI copied to clipboard"), + ("M-c", getTitle >>= Clipboard.insert >> notify 5000 "Page title copied to clipboard"), ("C-v", Clipboard.with $ parseURIReference >=> load), ("M-v", Clipboard.with $ \uri -> spawn "hbro" [uri]), -- Display diff --git a/Hbro/IPC.hs b/Hbro/IPC.hs --- a/Hbro/IPC.hs +++ b/Hbro/IPC.hs @@ -6,7 +6,7 @@ -- import Hbro.Error import Hbro.Util -import Control.Lens hiding(Context, Rep) +import Control.Lens hiding(Context) import Control.Monad.Base -- import Control.Monad.Error hiding(mapM_) -- import Control.Monad.Writer @@ -22,7 +22,7 @@ -- import System.Posix.Types -- import System.Process -import System.ZMQ3 hiding(close, init, message, receive, send, socket) +import System.ZMQ3 hiding(close, context, init, message, receive, send, socket) import qualified System.ZMQ3 as ZMQ (receive, send) -- }}} diff --git a/Hbro/Options.hs b/Hbro/Options.hs --- a/Hbro/Options.hs +++ b/Hbro/Options.hs @@ -4,6 +4,7 @@ CliOptions(), OptionsReader(..), startURI, + socketPath, help, quiet, verbose, @@ -15,7 +16,9 @@ dyreDebug, usage, get, - getStartURI) + getStartURI, + getSocketURI, + getUIFile) where -- {{{ Imports @@ -28,6 +31,8 @@ import Data.Default import Data.Functor +import Data.List +import Data.Maybe import Network.URI as N @@ -36,13 +41,17 @@ import System.Console.GetOpt import System.Directory import System.Environment +import System.Environment.XDG.BaseDir import System.FilePath +import System.Posix.Process -- }}} -- {{{ Types -- | Available commandline options (cf @hbro -h@). data CliOptions = CliOptions { _startURI :: Maybe String, + _socketPath :: Maybe FilePath, + _UIFile :: Maybe FilePath, _help :: Bool, _quiet :: Bool, _verbose :: Bool, @@ -57,21 +66,25 @@ makeLenses ''CliOptions instance Show CliOptions where - show opts = - (maybe "" ("URI=" ++) $ view startURI opts) - ++ (view help opts ? " HELP" ?? "") - ++ (view quiet opts ? " QUIET" ?? "") - ++ (view verbose opts ? " VERBOSE" ?? "") - ++ (view version opts ? " VERSION" ?? "") - ++ (view vanilla opts ? " VANILLA" ?? "") - ++ (view recompile opts ? " RECOMPILE" ?? "") - ++ (view denyReconf opts ? " DENY_RECONFIGURATION" ?? "") - ++ (view forceReconf opts ? " FORCE_RECONFIGURATION" ?? "") - ++ (view dyreDebug opts ? " DYRE_DEBUG" ?? "") + show opts = intercalate " " $ catMaybes [ + return . ("URI=" ++) =<< view startURI opts, + return . ("SOCKET=" ++) =<< view socketPath opts, + return . ("UI_FILE=" ++) =<< view uIFile opts, + view help opts ? Just "HELP" ?? Nothing, + view quiet opts ? Just "QUIET" ?? Nothing, + view verbose opts ? Just "VERBOSE" ?? Nothing, + view version opts ? Just "VERSION" ?? Nothing, + view vanilla opts ? Just "VANILLA" ?? Nothing, + view recompile opts ? Just "RECOMPILE" ?? Nothing, + view denyReconf opts ? Just "DENY_RECONFIGURATION" ?? Nothing, + view forceReconf opts ? Just "FORCE_RECONFIGURATION" ?? Nothing, + view dyreDebug opts ? Just "DYRE_DEBUG" ?? Nothing] instance Default CliOptions where def = CliOptions { _startURI = Nothing, + _socketPath = Nothing, + _UIFile = Nothing, _help = False, _quiet = False, _verbose = False, @@ -96,15 +109,17 @@ description :: [OptDescr (CliOptions -> CliOptions)] description = [ - Option ['h'] ["help"] (NoArg (\o -> o { _help = True })) "Print this help.", - Option ['q'] ["quiet"] (NoArg (\o -> o { _quiet = True })) "Do not print any log.", - Option ['v'] ["verbose"] (NoArg (\o -> o { _verbose = True })) "Print detailed logs.", - Option ['V'] ["version"] (NoArg (\o -> o { _version = True })) "Print version.", - Option ['1'] ["vanilla"] (NoArg (\o -> o { _vanilla = True })) "Do not read custom configuration file.", - Option ['r'] ["recompile"] (NoArg (\o -> o { _recompile = True })) "Only recompile configuration.", - Option [] ["deny-reconf"] (NoArg id) "Do not recompile configuration even if it has changed.", - Option [] ["force-reconf"] (NoArg id) "Recompile configuration before starting the program.", - Option [] ["dyre-debug"] (NoArg id) "Use './cache/' as the cache directory and ./ as the configuration directory. Useful to debug the program."] + Option ['h'] ["help"] (NoArg (set help True)) "Print this help", + Option ['q'] ["quiet"] (NoArg (set quiet True)) "Do not print any log", + Option ['v'] ["verbose"] (NoArg (set verbose True)) "Print detailed logs", + Option ['V'] ["version"] (NoArg (set version True)) "Print version", + Option ['1'] ["vanilla"] (NoArg (set vanilla True)) "Do not read custom configuration file", + Option ['r'] ["recompile"] (NoArg (set recompile True)) "Only recompile configuration", + Option ['s'] ["socket"] (ReqArg (\v -> set socketPath (Just v)) "PATH") "Where to open IPC socket", + Option ['u'] ["ui"] (ReqArg (\v -> set uIFile (Just v)) "PATH") "Path to UI descriptor (XML file)", + Option [] ["force-reconf"] (NoArg id) "Recompile configuration before starting the program", + Option [] ["deny-reconf"] (NoArg id) "Do not recompile configuration even if it has changed", + Option [] ["dyre-debug"] (NoArg id) "Use './cache/' as the cache directory and ./ as the configuration directory. Useful to debug the program"] -- | Usage text (cf @hbro -h@) usage :: String @@ -130,3 +145,19 @@ True -> io getCurrentDirectory >>= return . N.parseURIReference . ("file://" ++) . ( uri) _ -> return $ N.parseURIReference uri _ -> return Nothing + + +-- | Return socket URI used by this instance +getSocketURI :: (MonadBase IO m, OptionsReader m) => m String +getSocketURI = maybe getDefaultSocketURI (return . ("ipc://" ++)) =<< readOptions socketPath + where + getDefaultSocketURI = do + 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") diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE Version 2, December 2004 -Copyright (C) 2011 koral +Copyright (C) koral Everyone is permitted to copy and distribute verbatim or modified copies of this license document, and changing it is allowed as long diff --git a/README.rst b/README.rst --- a/README.rst +++ b/README.rst @@ -12,19 +12,20 @@ ----------------- `Do one thing well`_ - Browsing is about retrieving, presenting and traversing web resources. Not about providing tabs, bookmarks, history, download management, adblocking, passwords saving, self-updating, ... There already exists standalone applications for most extra features one may think of, please reuse them. *Hbro* can be configured to call external programs for any task. + A web browser is **not** a {window|bookmarks|history|download|passwords|package} manager, let alone an operating system. + A web browser retrieves, renders and traverses web pages, period. `Keep It Simple, Stupid`_ - *Hbro* is written with simplicity in mind, and without obsession for performance, features or release frequency. It should not take time to start-up, consume much RAM or crash. Simplicity provides lightweightness, scalability, stability and maintainability. Its code is easy to understand (well, as long as you speak Haskell...) to encourage users to hack it. + The program should be written with simplicity in mind, and without obsession for performance, features or release frequency. It should not take time to start-up, consume much RAM or crash. Its code should be easy to understand (well, as long as you speak Haskell...) to encourage users to hack it. Simplicity provides lightness, scalability, stability and maintainability. Extensible - Targets are advanced users who have various expectations ; to be sure everyone is happy, *hbro* is configured using a programming language, and offers an interprocess interface. As he who can do the most can do the least, the default configuration should be suitable for users that cannot afford or don't want to spend (waste ?) their time in tweaks. + Configuration system should allow users to implement extra features. External programs should be able to query/order *hbro*. -Keyboard driven - Special attention is given to allow keyboard control of the browser whenever possible. +Good defaults + A default configuration, suitable for users that cannot afford or don't want to spend (waste ?) their time in tweaks, should be provided. -Free software - Hbro is distributed under the `Do-What-The-Fuck-You-Want-To public licence`_, which has a pretty self-explanatory name. +Keyboard driven + Keyboard control should be made as much convenient, with as little mouse intervention, as possible. Components and libraries used @@ -52,28 +53,27 @@ 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. Several extensions are provided with the * hbro-contrib_ * package, including a featured and self-explanatory 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 well-commented example of configuration file. Known bugs and limitations -------------------------- -Patches or suggestions are welcome to deal with the following issues. See package description for contact address. +Unfortunately, many problems/limitations are inherited from the *Haskell* binding for *webkit*/*gtk*. Until fixed in upstream, nothing can be done on *hbro* to work around them. Here's a summary of them: -The browser crashes on loading some webpages, and on enabling javascript/flash - The demo webkit browser provided with haskell's binding crashes likewise, which suggests a problem in the haskell binding for webkit-gtk. Unfortunately, not much can be done on *hbro* itself to fix it. +- segfaults when loading some webpages or enabling javascript/flash; +- no proxy configuration; +- no cookies management; +- javascript's ``window.open`` requests open in the same window instead of spawning a new one; +- toggling to source mode reloads current webpage (which may be undesired) -.. Javascript's window.open requests open in the same window instead of spawning a new one. - This is due to this webkit's bug. +Patches or suggestions are welcome to deal with the following issues. -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. +License +------- -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. +*hbro* is distributed under the `Do-What-The-Fuck-You-Want-To public licence`_, which has a pretty self-explanatory name. .. _hackage: http://hackage.haskell.org/package/hbro @@ -85,5 +85,4 @@ .. _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 .. _hbro-contrib: http://hackage.haskell.org/package/hbro-contrib diff --git a/hbro.cabal b/hbro.cabal --- a/hbro.cabal +++ b/hbro.cabal @@ -1,5 +1,5 @@ Name: hbro -Version: 1.1.1.0 +Version: 1.1.2.0 Synopsis: Minimal KISS compliant browser -- Description: Homepage: http://projects.haskell.org/hbro/ @@ -46,7 +46,7 @@ unix, webkit, xdg-basedir, - zeromq3-haskell + zeromq3-haskell >= 0.2 Exposed-modules: Hbro, Hbro.Boot,