diff --git a/Hbro/Core.hs b/Hbro/Core.hs --- a/Hbro/Core.hs +++ b/Hbro/Core.hs @@ -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 diff --git a/Hbro/Extra/Bookmarks.hs b/Hbro/Extra/Bookmarks.hs deleted file mode 100644 --- a/Hbro/Extra/Bookmarks.hs +++ /dev/null @@ -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 diff --git a/Hbro/Extra/BookmarksQueue.hs b/Hbro/Extra/BookmarksQueue.hs deleted file mode 100644 --- a/Hbro/Extra/BookmarksQueue.hs +++ /dev/null @@ -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) - diff --git a/Hbro/Extra/Clipboard.hs b/Hbro/Extra/Clipboard.hs deleted file mode 100644 --- a/Hbro/Extra/Clipboard.hs +++ /dev/null @@ -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 diff --git a/Hbro/Extra/History.hs b/Hbro/Extra/History.hs deleted file mode 100644 --- a/Hbro/Extra/History.hs +++ /dev/null @@ -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 - diff --git a/Hbro/Extra/Misc.hs b/Hbro/Extra/Misc.hs deleted file mode 100644 --- a/Hbro/Extra/Misc.hs +++ /dev/null @@ -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 "Unable to go forward !" 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 "Unable to go back !" 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 diff --git a/Hbro/Extra/Session.hs b/Hbro/Extra/Session.hs deleted file mode 100644 --- a/Hbro/Extra/Session.hs +++ /dev/null @@ -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 - diff --git a/Hbro/Extra/StatusBar.hs b/Hbro/Extra/StatusBar.hs deleted file mode 100644 --- a/Hbro/Extra/StatusBar.hs +++ /dev/null @@ -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 $ "x" ++ escapeMarkup (show zoomLevel) ++ "" - - --- | -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 "" 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 () - diff --git a/Hbro/Gui.hs b/Hbro/Gui.hs --- a/Hbro/Gui.hs +++ b/Hbro/Gui.hs @@ -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) diff --git a/Hbro/Hbro.hs b/Hbro/Hbro.hs new file mode 100644 --- /dev/null +++ b/Hbro/Hbro.hs @@ -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 +-- }}} diff --git a/Hbro/Main.hs b/Hbro/Main.hs --- a/Hbro/Main.hs +++ b/Hbro/Main.hs @@ -1,7 +1,7 @@ module Main where -- {{{ Imports -import Hbro.Core +import Hbro.Hbro import Hbro.Types import Paths_hbro diff --git a/Hbro/Socket.hs b/Hbro/Socket.hs --- a/Hbro/Socket.hs +++ b/Hbro/Socket.hs @@ -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.") [] ), diff --git a/Hbro/Types.hs b/Hbro/Types.hs --- a/Hbro/Types.hs +++ b/Hbro/Types.hs @@ -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, diff --git a/Hbro/Util.hs b/Hbro/Util.hs --- a/Hbro/Util.hs +++ b/Hbro/Util.hs @@ -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 ++ ">.") diff --git a/README.rst b/README.rst --- a/README.rst +++ b/README.rst @@ -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 diff --git a/examples/hbro.hs b/examples/hbro.hs deleted file mode 100644 --- a/examples/hbro.hs +++ /dev/null @@ -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], ""), webViewGoBack webView), - (([Control], ""), webViewGoForward webView), - (([Alt], ""), (goBackList webView ["-l", "10"]) >>= maybe (return ()) (loadURI webView)), - (([Alt], ""), (goForwardList webView ["-l", "10"]) >>= maybe (return ()) (loadURI webView)), - (([Control], "s"), webViewStopLoading webView), - (([], ""), webViewReload webView), - (([Control], ""), webViewReloadBypassCache webView), - (([Control], "^"), goLeft scrolledWindow), - (([Control], "$"), goRight scrolledWindow), - (([Control], ""), goTop scrolledWindow), - (([Control], ""), goBottom scrolledWindow), - (([Alt], ""), 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), - (([], ""), windowFullscreen window), - (([], ""), 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 - (([], ""), 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 "Download started" 5000 - _ -> labelSetMarkupTemporary feedbackLabel "Unable to download" 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 () --- }}} diff --git a/examples/ui.xml b/examples/ui.xml --- a/examples/ui.xml +++ b/examples/ui.xml @@ -39,59 +39,14 @@ False 5 - - - - - False - False - - - - PANGO_ELLIPSIZE_END - 0 - 0 - - - - - + - GTK_PACK_END False False - - - - - GTK_PACK_END - False - False - - - - - - - GTK_PACK_END - False - False - - - - - - - GTK_PACK_END - False - False - - - @@ -99,7 +54,6 @@ False - diff --git a/hbro.cabal b/hbro.cabal --- a/hbro.cabal +++ b/hbro.cabal @@ -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,