diff --git a/Hbro/Boot.hs b/Hbro/Boot.hs new file mode 100644 --- /dev/null +++ b/Hbro/Boot.hs @@ -0,0 +1,106 @@ +module Hbro.Boot ( +-- * Commandline options + getOptions, +-- * Dynamic reconfiguration + printDyrePaths, + recompile, +-- * Boot + hbro +) where + +import qualified Hbro.Hbro as Hbro +import Hbro.Types +import Hbro.Util + +import qualified Config.Dyre as D +import Config.Dyre.Compile +import Config.Dyre.Paths + +import Control.Monad + +import Graphics.UI.Gtk.General.General hiding(initGUI) + +import System.Console.CmdArgs +import System.Exit +import System.IO +import System.Posix.Signals + + + + +-- {{{ Commandline options +cliOptions :: CliOptions +cliOptions = CliOptions { + mURI = def &= name "u" &= name "uri" &= typ "URI" &= help "URI to open at start-up" &= explicit, + mVanilla = def &= name "1" &= name "vanilla"&= help "Do not read custom configuration file." &= explicit, + mRecompile = def &= name "r" &= name "recompile" &= help "Force recompilation and do not launch browser." &= explicit, + mDenyReconf = def &= name "deny-reconf" &= help "Deny recompilation even if the configuration file has changed." &= explicit, + mForceReconf = def &= name "force-reconf" &= help "Force recompilation even if the configuration file hasn't changed." &= explicit, + mDyreDebug = def &= name "dyre-debug" &= help "Force the application to use './cache/' as the cache directory, and ./ as the configuration directory. Useful to debug the program without installation." &= explicit, + mMasterBinary = def &= name "dyre-master-binary" &= explicit +} + +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" +-- }}} + +-- {{{ Dynamic reconfiguration +printDyrePaths :: IO () +printDyrePaths = getPaths dyreParameters >>= \(a,b,c,d,e) -> (putStrLn . unlines) [ + "Current binary: " ++ a, + "Custom binary: " ++ b, + "Config file: " ++ c, + "Cache directory: " ++ d, + "Lib directory: " ++ e, []] + +-- | Launch a recompilation of the configuration file +recompile :: IO (Maybe String) +recompile = do + customCompile dyreParameters + getErrorString dyreParameters + +showError :: (Config', a) -> String -> (Config', a) +showError (_, x) message = (Left message, x) + +dyreParameters :: D.Params (Config', CliOptions) +dyreParameters = D.defaultParams { + D.projectName = "hbro", + D.showError = showError, + D.realMain = realMain, + D.ghcOpts = ["-threaded"], + D.statusOut = hPutStrLn stderr +} +-- }}} + +-- | Browser's main function. +-- To be called in main function with a proper configuration. +-- See Hbro.Main for an example. +hbro :: Config -> IO () +hbro config = do + options <- getOptions + + when (mRecompile options) $ + recompile + >>= maybe exitSuccess (\e -> putStrLn e >> exitFailure) + + case mVanilla options of + True -> D.wrapMain dyreParameters{ D.configCheck = False } (Right config, options) + _ -> D.wrapMain dyreParameters (Right config, options) + + +realMain :: (Config', CliOptions) -> IO () +realMain (Left e, _) = putStrLn e +realMain config = do + void $ installHandler sigINT (Catch interruptHandler) Nothing + whenLoud printDyrePaths + Hbro.main config + + +interruptHandler :: IO () +interruptHandler = logVerbose "Received SIGINT." >> mainQuit + diff --git a/Hbro/Config.hs b/Hbro/Config.hs --- a/Hbro/Config.hs +++ b/Hbro/Config.hs @@ -13,7 +13,7 @@ -- {{{ Import import Hbro.Core ---import Hbro.Keys +import Hbro.Keys import Hbro.Gui import qualified Hbro.Prompt as Prompt import Hbro.Types @@ -23,7 +23,6 @@ import Data.Foldable import Data.Functor -import qualified Data.Map as M import Graphics.UI.Gtk.Abstract.Widget import Graphics.UI.Gtk.General.General @@ -36,7 +35,6 @@ import Network.URI -import System.Console.CmdArgs (whenLoud) import System.FilePath import System.Glib.Attributes -- }}} @@ -76,16 +74,6 @@ -- | Warn user about missing download hook. defaultDownloadHook :: URI -> String -> Int -> K () defaultDownloadHook _ _ _ = notify 5000 "No download hook defined." - --- | Look for a callback associated to the given keystrokes and trigger it, if any. -defaultKeyHandler :: KeysList -> String -> K (String, Bool) -defaultKeyHandler keysList keystrokes = do - io . whenLoud . putStr $ "Key pressed: " ++ keystrokes - (log', isMapped) <- case M.lookup keystrokes (M.fromList keysList) of - Just callback -> callback >> return (" (mapped)", True) - _ -> return (" (unmapped)", False) - io . whenLoud . putStrLn $ log' - return (keystrokes, isMapped) -- | Default key bindings. defaultKeyBindings :: KeysList diff --git a/Hbro/Core.hs b/Hbro/Core.hs --- a/Hbro/Core.hs +++ b/Hbro/Core.hs @@ -130,7 +130,7 @@ loadURI :: URI -> K () loadURI uri = do - io . whenLoud . putStrLn . ("Loading URI: " ++) . show $ uri' + logVerbose $ "Loading URI: " ++ (show uri') with (mWebView . mGUI) (`webViewLoadUri` uri') where uri' = case uriScheme uri of diff --git a/Hbro/Hbro.hs b/Hbro/Hbro.hs --- a/Hbro/Hbro.hs +++ b/Hbro/Hbro.hs @@ -1,9 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DoRec #-} -module Hbro.Hbro ( --- * Main - launchHbro -) where +module Hbro.Hbro where -- {{{ Imports --import Hbro.Config @@ -15,15 +12,12 @@ import Hbro.Types import Hbro.Util -import qualified Config.Dyre as D -import Config.Dyre.Compile -import Config.Dyre.Paths - --import Control.Concurrent import Control.Monad.Reader hiding(forM_, mapM_) import Data.Dynamic import Data.Foldable +import Data.Functor import Data.IORef import qualified Data.Map as M @@ -45,97 +39,26 @@ import System.Console.CmdArgs import System.Directory -import System.Exit 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", - mRecompile = def &= help "Force recompilation and do not launch browser." &= explicit &= name "r" &= name "recompile", - 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" --- }}} - --- {{{ Util -printDyrePaths :: IO () -printDyrePaths = getPaths dyreParameters >>= \(a,b,c,d,e) -> (putStrLn . unlines) [ - "Current binary: " ++ a, - "Custom binary: " ++ b, - "Config file: " ++ c, - "Cache directory: " ++ d, - "Lib directory: " ++ e, []] - --- | Launch a recompilation of the configuration file -recompile :: IO (Maybe String) -recompile = do - customCompile dyreParameters - getErrorString dyreParameters - -showError :: (Config', a) -> String -> (Config', a) -showError (_, x) message = (Left message, x) --- }}} - --- {{{ Entry point -dyreParameters :: D.Params (Config', CliOptions) -dyreParameters = D.defaultParams { - D.projectName = "hbro", - D.showError = showError, - D.realMain = realMain, - D.ghcOpts = ["-threaded"], - D.statusOut = hPutStrLn stderr -} - --- | Browser's main function. --- To be called in main function with a proper configuration. --- See Hbro.Main for an example. -launchHbro :: Config -> IO () -launchHbro config = do - options <- getOptions --- Handle recompilation - when (mRecompile options) $ - recompile - >>= maybe exitSuccess (\e -> putStrLn e >> exitFailure) --- Handle vanilla mode - case mVanilla options of - True -> D.wrapMain dyreParameters{ D.configCheck = False } (Right config, options) - _ -> D.wrapMain dyreParameters (Right config, options) - -- At this point, the reconfiguration process is done -realMain :: (Config', CliOptions) -> IO () -realMain (Left e, _) = putStrLn e -realMain (Right config, options) = do --- Handle SIGINT - void $ installHandler sigINT (Catch interruptHandler) Nothing --- Print configuration state - whenLoud printDyrePaths +main :: (Config', CliOptions) -> IO () +main (Left e, _) = putStrLn e +main (Right config, options) = do -- Initialize GUI, state and IPC socket gui <- initGUI (mUIFile config) (mWebSettings config) state <- newIORef (M.empty :: M.Map String Dynamic) - ZMQ.withContext 1 $ \context -> realMain' (Environment state options config gui context) + ZMQ.withContext 1 $ \context -> main' (Environment state options config gui context) whenNormal . putStrLn $ "Exiting..." -realMain' :: Environment -> IO () -realMain' environment@Environment{ mOptions = options, mConfig = config, mGUI = gui} = let +main' :: Environment -> IO () +main' environment@Environment{ mOptions = options, mConfig = config, mGUI = gui} = let entry = (mEntry . mPromptBar) gui webView = mWebView gui hooks = mHooks config @@ -173,21 +96,18 @@ io mainGUI Socket.close - -interruptHandler :: IO () -interruptHandler = whenLoud (putStrLn "Received SIGINT.") >> mainQuit -- }}} -- {{{ Hooks onDownload :: Environment -> Download -> IO Bool onDownload environment download = do - uri <- (>>= parseURI) `fmap` downloadGetUri download + uri <- fmap (>>= parseURI) . downloadGetUri $ download filename <- downloadGetSuggestedFilename download size <- downloadGetTotalSize download case (uri, filename) of (Just uri', Just filename') -> do - whenLoud . putStrLn . ("Requested download: " ++) . show $ uri' + logVerbose . ("Requested download: " ++) . show $ uri' runK environment $ do notify 5000 $ "Requested download: " ++ filename' ++ " (" ++ show size ++ ")" callback uri' filename' size @@ -199,10 +119,11 @@ onKeyPressed :: Environment -> EventM EKey Bool onKeyPressed env = do modifiers <- eventModifier - key' <- keyToString `fmap` eventKeyVal + key' <- keyToString <$> eventKeyVal io . forM_ key' $ \key -> do let keystrokes = (++ key) . concat . map stringify $ modifiers + logVerbose $ "Key pressed: " ++ keystrokes runK env $ (mKeyPressed hooks) keystrokes return False where @@ -255,7 +176,6 @@ return True - -- Triggered in 2 cases: -- 1/ Javascript window.open() -- 2/ Context menu "Open in new window" @@ -304,8 +224,6 @@ -- onTitleChanged :: Environment -> WebFrame -> String -> IO () onTitleChanged env _frame title = do - whenLoud . putStrLn . ("Title changed: " ++) $ title - runK env $ hook title - where - hook = mTitleChanged . mHooks . mConfig $ env + logVerbose $ "Title changed: " ++ title + runK env $ (mTitleChanged . mHooks . mConfig $ env) title -- }}} diff --git a/Hbro/Keys.hs b/Hbro/Keys.hs --- a/Hbro/Keys.hs +++ b/Hbro/Keys.hs @@ -1,10 +1,11 @@ {-# LANGUAGE DoRec #-} module Hbro.Keys ( -- * Other + defaultKeyHandler, + emacsKeyHandler, -- * Util stringify, keyToString, - manageSequentialKeys ) where -- {{{ Imports @@ -17,7 +18,7 @@ --import Data.Foldable import Data.IORef ---import qualified Data.Map as M +import qualified Data.Map as M --import qualified Data.Set as S import Graphics.UI.Gtk.Abstract.Widget @@ -30,24 +31,31 @@ --import System.Glib.Signals -- }}} +-- | Look for a callback associated to the given keystrokes and trigger it, if any. +defaultKeyHandler :: KeysList -> String -> K (String, Bool) +defaultKeyHandler keysList keystrokes = case M.lookup keystrokes (M.fromList keysList) of + Just callback -> callback >> return (keystrokes, True) + _ -> return (keystrokes, False) -manageSequentialKeys :: (String -> K (String, Bool)) -> String -> K (String, Bool) -manageSequentialKeys handler keystroke = do - keysRef <- getState "Hbro.Keys.manageSequentialKeys" "" - keys <- io $ manageSequentialKeys' keysRef keystroke - (keys', result) <- handler keys - case result of - True -> (io . modifyIORef keysRef $ const []) >> return ([], result) - _ -> return (keys', result) +-- | Emacs-like key handler. +emacsKeyHandler :: KeysList -- ^ Key bindings + -> [String] -- ^ List of prefix keys + -> String + -> K (String, Bool) +emacsKeyHandler keysList prefixes keystrokes = do + keysRef <- getState "Hbro.Keys.manageSequentialKeys" "" + io $ modifyIORef keysRef (++ keystrokes) + chainedKeys <- io $ readIORef keysRef -manageSequentialKeys' :: IORef String -> String -> IO String -manageSequentialKeys' previousKeys "" = do - writeIORef previousKeys [] - return [] -manageSequentialKeys' previousKeys keystroke = do - modifyIORef previousKeys (++ keystroke) - return =<< readIORef previousKeys - + case elem chainedKeys prefixes of + True -> do + io $ modifyIORef keysRef (++ " ") + return (chainedKeys ++ " ", False) + _ -> do + io $ writeIORef keysRef [] + defaultKeyHandler keysList chainedKeys + + -- | Convert a KeyVal to a String. -- For printable characters, the corresponding String is returned, except for the space character for which "" is returned. -- For non-printable characters, the corresponding keyName wrapped into "< >" is returned. diff --git a/Hbro/Main.hs b/Hbro/Main.hs --- a/Hbro/Main.hs +++ b/Hbro/Main.hs @@ -1,8 +1,8 @@ module Main where -- {{{ Imports +import Hbro.Boot import Hbro.Config -import Hbro.Hbro import Hbro.Types import Paths_hbro @@ -13,6 +13,6 @@ main = do uiFile <- getDataFileName "examples/ui.xml" - launchHbro $ defaultConfig { + hbro $ defaultConfig { mUIFile = const uiFile } diff --git a/Hbro/Prompt.hs b/Hbro/Prompt.hs --- a/Hbro/Prompt.hs +++ b/Hbro/Prompt.hs @@ -22,8 +22,6 @@ import Network.URI import Prelude hiding(mapM_) - -import System.Console.CmdArgs (whenLoud) -- }}} init :: Builder -> IO PromptBar @@ -40,7 +38,7 @@ open :: String -> String -> K () open newDescription defaultText = with (mPromptBar . mGUI) $ \(PromptBar promptBox description entry _ _) -> do - whenLoud . putStrLn $ "Opening prompt." + logVerbose "Opening prompt." labelSetText description newDescription entrySetText entry defaultText diff --git a/Hbro/Socket.hs b/Hbro/Socket.hs --- a/Hbro/Socket.hs +++ b/Hbro/Socket.hs @@ -12,9 +12,8 @@ --import Data.Foldable import qualified Data.Map as M -import Prelude hiding(mapM_) +import Prelude hiding(log, mapM_) -import System.Console.CmdArgs (whenNormal, whenLoud) import System.FilePath import System.Posix.Process import System.Posix.Types @@ -29,7 +28,7 @@ socketURI <- with (mSocketDir . mConfig) $ resolve >=> (return . (socketFile pid)) -- Open socket and listen to commands mapK (void . forkIO) $ withK mContext $ \context -> do - io . whenNormal . putStrLn . ("Opening socket at " ++) $ socketURI + logNormal $ "Opening socket at " ++ socketURI mapK2 (withSocket context Rep) $ \sock -> do io $ bind sock socketURI readCommands sock @@ -39,8 +38,8 @@ -- Typically called when exiting application. close :: K () close = getURI >>= \uri -> do - (io . whenLoud . putStrLn . ("Closing socket " ++) . (++ " ...")) uri - (void . (`sendCommand` "QUIT")) uri + logVerbose . ("Closing socket " ++) . (++ " ...") $ uri + void . (`sendCommand` "QUIT") $ uri -- | Listen for incoming requests from response socket. @@ -54,11 +53,11 @@ [] -> io $ send sock (pack "ERROR Unknown command") [] -- Exit command ["QUIT"] -> io $ do - whenLoud . putStrLn $ "Receiving QUIT command" + logVerbose "Receiving QUIT command" send sock (pack "OK") [] -- Valid command command:arguments -> withK (M.fromList . mCommands . mConfig) $ \commands -> do - io . whenLoud . putStrLn . ("Receiving command: " ++) $ message + logVerbose . ("Receiving command: " ++) $ message case M.lookup command commands of Just callback -> callback arguments >>= io . (send'' sock) . pack _ -> io $ send sock (pack "ERROR Unknown command") [] diff --git a/Hbro/Types.hs b/Hbro/Types.hs --- a/Hbro/Types.hs +++ b/Hbro/Types.hs @@ -26,7 +26,7 @@ import Network.URI import System.Console.CmdArgs -import System.Glib.Attributes +import System.Glib.Attributes hiding(get) --import System.Glib.Signals import System.ZMQ -- }}} diff --git a/Hbro/Util.hs b/Hbro/Util.hs --- a/Hbro/Util.hs +++ b/Hbro/Util.hs @@ -1,6 +1,8 @@ module Hbro.Util ( -- * General purpose io, + logNormal, + logVerbose, resolve, -- * Process management spawn, @@ -35,6 +37,8 @@ import Graphics.UI.Gtk.Display.Label import Graphics.UI.Gtk.General.General +import Prelude hiding(log) + import System.Console.CmdArgs import System.Directory import System.Environment.XDG.BaseDir @@ -53,6 +57,10 @@ send'' :: Socket a -> ByteString -> IO () send'' x y = send x y [] + +logNormal, logVerbose :: (MonadIO m) => String -> m () +logNormal = io . whenNormal . putStrLn +logVerbose = io . whenLoud . putStrLn -- | resolve :: (RefDirs -> a) -> IO a diff --git a/README.rst b/README.rst --- a/README.rst +++ b/README.rst @@ -26,7 +26,7 @@ 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 +Keyboard driven 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 diff --git a/hbro.cabal b/hbro.cabal --- a/hbro.cabal +++ b/hbro.cabal @@ -1,5 +1,5 @@ Name: hbro -Version: 0.9.0.0 +Version: 0.9.1.0 Synopsis: Minimal KISS compliant browser -- Description: Homepage: http://projects.haskell.org/hbro/ @@ -33,7 +33,7 @@ dyre, filepath, glib, - gtk, + gtk >= 0.12.3, mtl, network, pango, @@ -44,6 +44,7 @@ xdg-basedir, zeromq-haskell Exposed-modules: + Hbro.Boot, Hbro.Config, Hbro.Core, Hbro.Gui,