diff --git a/Hbro/Core.hs b/Hbro/Core.hs --- a/Hbro/Core.hs +++ b/Hbro/Core.hs @@ -1,5 +1,20 @@ -{-# LANGUAGE OverloadedStrings #-} -module Hbro.Core where +{-# LANGUAGE OverloadedStrings #-} +module Hbro.Core ( +-- * Main + defaultConfig, + launchHbro, +-- * Browsing + goHome, + loadURI, +-- * Scrolling + goTop, + goBottom, + goLeft, + goRight, +-- * Misc + printPage, + executeJSFile +) where -- {{{ Imports import Hbro.Gui @@ -11,20 +26,18 @@ import Config.Dyre.Paths import Control.Concurrent -import Control.Monad.Trans(liftIO) +import Control.Monad.Reader -import Data.ByteString.Char8 (pack) import qualified Data.Map as Map import qualified Data.Set as Set import Graphics.UI.Gtk.Abstract.Widget -import Graphics.UI.Gtk.General.General +import Graphics.UI.Gtk.General.General hiding(initGUI) import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.Misc.Adjustment import Graphics.UI.Gtk.Scrolling.ScrolledWindow import Graphics.UI.Gtk.WebKit.WebDataSource import Graphics.UI.Gtk.WebKit.WebFrame -import Graphics.UI.Gtk.WebKit.WebSettings import Graphics.UI.Gtk.WebKit.WebView import Network.URL @@ -33,13 +46,12 @@ import System.Directory import System.Glib.Signals import System.IO -import System.Process import System.Posix.Process +import System.Posix.Signals import qualified System.ZMQ as ZMQ -- }}} -- {{{ Commandline options --- | Available commandline options cliOptions :: CliOptions cliOptions = CliOptions { mURI = def &= help "URI to open at start-up" &= explicit &= name "u" &= name "uri" &= typ "URI" @@ -49,13 +61,13 @@ getOptions = cmdArgs $ cliOptions     &= verbosityArgs [explicit, name "Verbose", name "v"] []     &= versionArg [ignore] -    &= help "A suckless minimal KISSy browser." +    &= help "A minimal KISS-compliant browser."     &= helpArg [explicit, name "help", name "h"]     &= program "hbro" -- }}} --- {{{ Configuration -dyreParameters :: D.Params Configuration +-- {{{ Configuration (Dyre) +dyreParameters :: D.Params Config dyreParameters = D.defaultParams { D.projectName = "hbro", D.showError = showError, @@ -64,19 +76,20 @@ D.statusOut = hPutStrLn stderr } -showError :: Configuration -> String -> Configuration -showError configuration message = configuration { mError = Just message } +showError :: Config -> String -> Config +showError config message = config { mError = Just message } -- | Default configuration. --- Does quite nothing. -defaultConfiguration :: Configuration -defaultConfiguration = Configuration { - mHomePage = "https://www.google.com", - mSocketDir = "/tmp/", - mUIFile = "~/.config/hbro/ui.xml", - mKeys = [], - mWebSettings = webSettingsNew, - mSetup = \_ -> return () :: IO (), +-- Homepage: Google, socket directory: /tmp, +-- UI file: ~/.config/hbro/, no key/command binding. +defaultConfig :: FilePath -> FilePath -> Config +defaultConfig home tmp = Config { + mHomePage = "https://encrypted.google.com/", + mSocketDir = tmp, + mUIFile = home ++ "/.config/hbro/ui.xml", + mKeys = const [], + mWebSettings = [], + mSetup = const (return () :: IO ()), mCommands = [], mError = Nothing } @@ -84,73 +97,58 @@ -- {{{ Entry point -- | Browser's main function. --- To be called in function "main" with a proper configuration. -hbro :: Configuration -> IO () -hbro = D.wrapMain dyreParameters +-- To be called in main function with a proper configuration. +-- See Hbro.Main for an example. +launchHbro :: Config -> IO () +launchHbro = D.wrapMain dyreParameters --- | Entry point for the application. --- Parse commandline arguments, print configuration error if any, --- create browser and load homepage. -realMain :: Configuration -> IO () +realMain :: Config -> IO () realMain config = do +-- Print configuration error, if any + maybe (return ()) putStrLn $ mError config + -- Parse commandline arguments options <- getOptions -- Print in-use paths - (a, b, c, d, e) <- getPaths dyreParameters - whenLoud $ do + getPaths dyreParameters >>= \(a,b,c,d,e) -> whenLoud $ do putStrLn ("Current binary: " ++ a) putStrLn ("Custom binary: " ++ b) putStrLn ("Config file: " ++ c) putStrLn ("Cache directory: " ++ d) putStrLn ("Lib directory: " ++ e) putStrLn "" - --- Print configuration error, if any - maybe (return ()) putStrLn $ mError config - + -- Initialize GUI - _ <- initGUI - gui <- loadGUI $ mUIFile config - let browser = Browser options config gui - let webView = mWebView gui - let window = mWindow gui - - _ <- onDestroy window mainQuit - widgetShowAll window - showPrompt False browser - --- Load additionnal settings from configuration - settings <- mWebSettings config - webViewSetWebSettings webView settings - (mSetup config) browser + gui <- initGUI (mUIFile config) (mWebSettings config) --- Load key bindings - let keyBindings = importKeyBindings (mKeys config) +-- Initialize IPC socket + ZMQ.withContext 1 $ realMain' config options gui --- 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 () - return webView +realMain' :: Config -> CliOptions -> GUI -> ZMQ.Context -> IO () +realMain' config options gui@GUI {mWebView = webView, mWindow = window} context = let + environment = Environment options config gui context + keys = importKeyBindings $ (mKeys config) environment + setup = mSetup config + socketDir = mSocketDir config + commands = mCommands config + in do +-- Apply custom setup + setup environment -- Manage keys - _ <- after webView keyPressEvent $ do + _ <- after window keyPressEvent $ do value <- eventKeyVal modifiers <- eventModifier let keyString = keyToString value case keyString of - Just "" -> liftIO $ showPrompt False browser + Just "" -> liftIO $ widgetHide ((mBox . mPromptBar) gui) Just string -> do - case Map.lookup (Set.fromList modifiers, string) keyBindings of + case Map.lookup (Set.fromList modifiers, string) keys of Just callback -> do - liftIO $ callback browser + liftIO $ callback liftIO $ whenLoud (putStrLn $ "Key pressed: " ++ show modifiers ++ string ++ " (mapped)") _ -> liftIO $ whenLoud (putStrLn $ "Key pressed: " ++ show modifiers ++ string ++ " (unmapped)") _ -> return () @@ -162,164 +160,116 @@ Just uri -> do fileURI <- doesFileExist uri case fileURI of - True -> getCurrentDirectory >>= \cwd -> webViewLoadUri webView $ "file://" ++ cwd ++ "/" ++ uri + True -> getCurrentDirectory >>= \dir -> webViewLoadUri webView $ "file://" ++ dir ++ "/" ++ uri _ -> webViewLoadUri webView uri whenLoud $ putStrLn ("Loading " ++ uri ++ "...") - _ -> goHome browser - + _ -> goHome webView config --- Initialize IPC socket - pid <- getProcessID - let socketURI = "ipc://" ++ (mSocketDir config) ++ "/hbro." ++ show pid +-- Open socket + pid <- getProcessID + let commandsList = Map.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 - - ZMQ.withContext 1 $ \context -> do - _ <- forkIO $ createRepSocket context socketURI browser - - mainGUI -- Main loop + mainGUI -- Main loop - -- Make sure response socket is closed at exit - whenLoud $ putStrLn "Closing socket..." - ZMQ.withSocket context ZMQ.Req $ \reqSocket -> do - ZMQ.connect reqSocket socketURI - ZMQ.send reqSocket (pack "Quit") [] - _ <- ZMQ.receive reqSocket [] - return () +-- Make sure response socket is closed at exit + whenLoud $ putStrLn "Closing socket..." + closeSocket context socketURI + whenNormal $ putStrLn "Exiting..." - whenNormal $ putStrLn "Exiting..." +interruptHandler :: IO () +interruptHandler = do + whenLoud $ putStrLn "Received SIGINT." + mainQuit -- }}} -- {{{ Browsing functions -- | Load homepage (set from configuration file). -goHome :: Browser -> IO () -goHome browser = do +goHome :: WebView -> Config -> IO () +goHome webView config = do whenLoud $ putStrLn ("Loading homepage: " ++ uri) - loadURI uri browser + loadURI webView uri where - uri = mHomePage $ mConfiguration browser - --- | Wrapper around webViewGoBack function, provided for convenience. -goBack :: Browser -> IO () -goBack browser = webViewGoBack (mWebView $ mGUI browser) - --- | Wrapper around webViewGoForward function, provided for convenience. -goForward :: Browser -> IO () -goForward browser = webViewGoForward (mWebView $ mGUI browser) - --- | Wrapper around webViewStopLoading function, provided for convenience. -stopLoading :: Browser -> IO () -stopLoading browser = webViewStopLoading (mWebView $ mGUI browser) - --- | Wrapper around webViewReload{BypassCache}. -reload - :: Bool -- ^ If False, cache is bypassed. - -> Browser - -> IO () -reload True browser = webViewReload (mWebView $ mGUI browser) -reload _ browser = webViewReloadBypassCache (mWebView $ mGUI browser) - --- | Load given URL in the browser. -loadURI :: String -> Browser -> IO () -loadURI url browser = - case importURL url of - Just url' -> do - whenLoud $ putStrLn ("Loading URI: " ++ url) - loadURI' url' browser - _ -> putStrLn $ "WARNING: not a valid URI: " ++ url - --- | Backend function for loadURI. -loadURI' :: URL -> Browser -> IO () -loadURI' uri@URL {url_type = Absolute _} browser = - webViewLoadUri (mWebView $ mGUI browser) (exportURL uri) -loadURI' uri@URL {url_type = HostRelative} browser = - webViewLoadUri (mWebView $ mGUI browser) ("file://" ++ exportURL uri) -loadURI' uri@URL {url_type = _} browser = - webViewLoadUri (mWebView $ mGUI browser) ("http://" ++ exportURL uri) --- }}} - - --- {{{ Zoom --- | Wrapper around webViewZoomIn function, provided for convenience. -zoomIn :: Browser -> IO () -zoomIn browser = webViewZoomIn (mWebView $ mGUI browser) + uri = mHomePage config --- | Wrapper around webViewZoomOut function, provided for convenience. -zoomOut :: Browser -> IO () -zoomOut browser = webViewZoomOut (mWebView $ mGUI browser) +-- | 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) -- }}} - --- | Wrapper around webFramePrint function, provided for convenience. -printPage :: Browser -> IO() -printPage browser = do - frame <- webViewGetMainFrame (mWebView $ mGUI browser) - webFramePrint frame - - -- {{{ Scrolling -- | Scroll up to top of web page. Provided for convenience. -verticalHome :: Browser -> IO () -verticalHome browser = do - adjustment <- scrolledWindowGetVAdjustment (mScrollWindow $ mGUI browser) +goTop :: ScrolledWindow -> IO () +goTop window = do + adjustment <- scrolledWindowGetVAdjustment window lower <- adjustmentGetLower adjustment adjustmentSetValue adjustment lower - -- | Scroll down to bottom of web page. Provided for convenience. -verticalEnd :: Browser -> IO () -verticalEnd browser = do - adjustment <- scrolledWindowGetVAdjustment (mScrollWindow $ mGUI browser) +goBottom :: ScrolledWindow -> IO () +goBottom window = do + adjustment <- scrolledWindowGetVAdjustment window upper <- adjustmentGetUpper adjustment adjustmentSetValue adjustment upper -- | Scroll to the left edge of web page. Provided for convenience. -horizontalHome :: Browser -> IO () -horizontalHome browser = do - adjustment <- scrolledWindowGetHAdjustment (mScrollWindow $ mGUI browser) +goLeft :: ScrolledWindow -> IO () +goLeft window = do + adjustment <- scrolledWindowGetHAdjustment window lower <- adjustmentGetLower adjustment adjustmentSetValue adjustment lower -- | Scroll to the right edge of web page. Provided for convenience. -horizontalEnd :: Browser -> IO () -horizontalEnd browser = do - adjustment <- scrolledWindowGetHAdjustment (mScrollWindow $ mGUI browser) +goRight :: ScrolledWindow -> IO () +goRight window = do + adjustment <- scrolledWindowGetHAdjustment window upper <- adjustmentGetUpper adjustment adjustmentSetValue adjustment upper -- }}} +-- {{{ Misc +-- | Wrapper around webFramePrint function, provided for convenience. +printPage :: WebView -> IO () +printPage webView = do + frame <- webViewGetMainFrame webView + webFramePrint frame --- | Spawn a new instance of the browser. -newInstance :: IO () -newInstance = do - (binary, _, _, _, _) <- getPaths dyreParameters - spawn $ proc binary [] -- | Execute a javascript file on current webpage. -executeJSFile :: String -> Browser -> IO () -executeJSFile filePath browser = do +executeJSFile :: String -> WebView -> IO () +executeJSFile filePath webView = do whenNormal $ putStrLn ("Executing Javascript file: " ++ filePath) script <- readFile filePath let script' = unwords . map (\line -> line ++ "\n") . lines $ script - webViewExecuteScript (mWebView $ mGUI browser) script' + webViewExecuteScript webView script' +-- }}} -- | Save current web page to a file, -- along with all its resources in a separated directory. -- Doesn't work for now, because web_resource_get_data's binding is missing... -savePage :: String -> Browser -> IO () -savePage _path browser = do +_savePage :: String -> WebView -> IO () +_savePage _path webView = do frame <- webViewGetMainFrame webView dataSource <- webFrameGetDataSource frame _mainResource <- webDataSourceGetMainResource dataSource _subResources <- webDataSourceGetSubresources dataSource return () - - where - webView = mWebView $ mGUI browser diff --git a/Hbro/Extra/Bookmarks.hs b/Hbro/Extra/Bookmarks.hs --- a/Hbro/Extra/Bookmarks.hs +++ b/Hbro/Extra/Bookmarks.hs @@ -1,134 +1,69 @@ module Hbro.Extra.Bookmarks ( - addWithTags, - addAllWithTags, - load, - loadWithTag, + select, + selectTag, deleteWithTag, add, ) where -- {{{ Imports -import Hbro.Core -import Hbro.Gui -import Hbro.Types +--import Hbro.Core +--import Hbro.Gui +--import Hbro.Types import Hbro.Util -import qualified Data.ByteString.Char8 as B +--import qualified Data.ByteString.Char8 as B import Data.List import qualified Data.Text as T import qualified Data.Text.IO as T - -import Graphics.UI.Gtk.Entry.Entry -import Graphics.UI.Gtk.WebKit.WebView - -import System.Environment -import qualified System.Info as Sys -import System.IO -import System.Posix.Process -import System.Process -import System.ZMQ -- }}} --- | Add current URI to bookmarks. --- Prompt for a tags list to apply. -addWithTags :: Browser -> IO () -addWithTags browser = do - uri <- webViewGetUri (mWebView $ mGUI browser) - case uri of - Just u -> prompt "Bookmark with tags:" "" False browser (\b -> do - tags <- entryGetText (mPromptEntry $ mGUI b) - add u (words tags)) - _ -> return () +-- | The elementary bookmark action +add :: FilePath -> String -> [String] -> IO () +add bookmarksFile uri tags = appendFile bookmarksFile $ uri ++ " " ++ (unwords tags) ++ "\n" --- | Add current URIs from all opened windows to bookmarks. -addAllWithTags :: Browser -> IO () -addAllWithTags browser = - prompt "Bookmark all instances with tag:" "" False browser (\b -> do - tags <- entryGetText (mPromptEntry $ mGUI b) - uri <- webViewGetUri (mWebView $ mGUI browser) - case uri of - Just u -> add u $ words tags - _ -> return () - (_, pids, _) <- readProcessWithExitCode "pidof" ["hbro"] [] - (_, pids', _) <- readProcessWithExitCode "pidof" ["hbro-" ++ Sys.os ++ "-" ++ Sys.arch] [] - myPid <- getProcessID - - let pidsList = delete (show myPid) . nub . words $ pids ++ " " ++ pids' - let bookmarkPID = (\pid -> withContext 1 $ \context -> do - withSocket context Req $ \reqSocket -> - let - socketURI = "ipc://" ++ (mSocketDir $ mConfiguration browser) ++ "/hbro." ++ pid - in do - connect reqSocket socketURI - - send reqSocket (B.pack "getUri") [] - uri' <- receive reqSocket [] - - add (B.unpack uri') (words tags) - ) - - _ <- mapM bookmarkPID pidsList - return ()) - -- | -load :: Browser -> IO () -load browser = do - -- Load bookmarks file - configHome <- getEnv "XDG_CONFIG_HOME" - file <- T.readFile $ configHome ++ "/hbro/bookmarks" - - -- Reformat lines +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 - (Just input, Just output, _, _) <- createProcess (proc "dmenu" ["-l", "10"]) { - std_in = CreatePipe, - std_out = CreatePipe } - _ <- T.hPutStr input file' +-- Let user select a URI + selection <- dmenu dmenuOptions file' - entry <- catch (hGetLine output) (\_error -> return "ERROR" ) - case reverse . words $ entry of - ["ERROR"] -> return () - uri:_ -> loadURI uri browser - _ -> return () + case reverse . words $ selection of + [] -> return Nothing + uri:_ -> return $ Just uri reformat :: T.Text -> T.Text -reformat line = - T.unwords $ tags' ++ [uri] +reformat line = T.unwords $ tags' ++ [uri] where uri:tags = T.words line tags' = sort $ map (\tag -> T.snoc (T.cons '[' tag) ']') tags -- | -loadWithTag :: IO () -loadWithTag = do +selectTag :: FilePath -> [String] -> IO (Maybe [String]) +selectTag bookmarksFile dmenuOptions = do -- Read bookmarks file - configHome <- getEnv "XDG_CONFIG_HOME" - file <- T.readFile $ configHome ++ "/hbro/bookmarks" + 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 - (Just input, Just output, _, _) <- createProcess (proc "dmenu" ["-l", "10"]) { - std_in = CreatePipe, - std_out = CreatePipe } - _ <- T.hPutStr input list + selection <- dmenu dmenuOptions list - tag <- catch (hGetLine output) (\_error -> return "ERROR" ) - case tag of - "ERROR" -> return () - "" -> return () - t -> do - _ <- mapM (\uri -> spawn (proc "hbro" ["-u", (T.unpack uri)])) uris - return () + 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 t) (T.lines file) - uris = map getUri file' + file' = filter (tagFilter $ T.pack tag) (T.lines file) + uris = map (T.unpack . getUri) file' -- tagFilter :: T.Text -> T.Text -> Bool @@ -138,35 +73,21 @@ -- | -deleteWithTag :: IO () -deleteWithTag = do - configHome <- getEnv "XDG_CONFIG_HOME" - file <- T.readFile $ configHome ++ "/hbro/bookmarks" +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) - (Just input, Just output, _, _) <- createProcess (proc "dmenu" []) { - std_in = CreatePipe, - std_out = CreatePipe } - _ <- T.hPutStr input tagsList - - tag <- catch (hGetLine output) (\_error -> return "ERROR" ) - case tag of - "ERROR" -> return () + selection <- dmenu dmenuOptions tagsList + case selection of "" -> return () _ -> do - T.writeFile (configHome ++ "/hbro/bookmarks.old") file - T.writeFile (configHome ++ "/hbro/bookmarks") file' + T.writeFile (bookmarksFile ++ ".old") file + T.writeFile bookmarksFile file' return () where - file' = T.unlines $ filter (not . (tagFilter $ T.pack tag)) (T.lines file) - - --- | The elementary bookmark action -add :: String -> [String] -> IO () -add uri tags = do - configHome <- getEnv "XDG_CONFIG_HOME" - appendFile (configHome ++ "/hbro/bookmarks") $ uri ++ " " ++ (unwords tags) ++ "\n" + file' = T.unlines $ filter (not . (tagFilter $ T.pack selection)) (T.lines file) -- | getTags :: T.Text -> T.Text diff --git a/Hbro/Extra/BookmarksQueue.hs b/Hbro/Extra/BookmarksQueue.hs --- a/Hbro/Extra/BookmarksQueue.hs +++ b/Hbro/Extra/BookmarksQueue.hs @@ -1,53 +1,39 @@ module Hbro.Extra.BookmarksQueue where -- {{{ Imports -import Hbro.Types +--import Hbro.Types import Data.List import qualified Data.Text as T import qualified Data.Text.IO as T - -import Graphics.UI.Gtk.WebKit.WebView - -import System.Environment -- }}} -- | Add current URI to the end of the queue. -append :: Browser -> IO () -append browser = do - uri <- webViewGetUri (mWebView $ mGUI browser) - configHome <- getEnv "XDG_CONFIG_HOME" - - case uri of - Just u -> appendFile (configHome ++ "/hbro/queue") (u ++ "\n") - _ -> return () +--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 :: Browser -> IO () -push browser = do - uri <- webViewGetUri (mWebView $ mGUI browser) - configHome <- getEnv "XDG_CONFIG_HOME" - file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\_error -> return T.empty) - - case uri of - Just u -> - if (file == T.empty) - then return () - else do - let fileLines = T.lines file - let file' = T.unlines . nub $ (T.pack u):fileLines - - T.writeFile (configHome ++ "/hbro/queue") file' +push :: String -> String -> IO () +push bookmarksFile uri = do + file <- catch (T.readFile bookmarksFile) (\_error -> return T.empty) - return () - _ -> return () + 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 :: IO String -popFront = do - configHome <- getEnv "XDG_CONFIG_HOME" - file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\_error -> return T.empty) +popFront :: String -> IO String +popFront bookmarksFile = do + file <- catch (T.readFile bookmarksFile) (\_error -> return T.empty) if file == T.empty then return "" @@ -55,16 +41,15 @@ let fileLines = T.lines file let file' = T.unlines . tail . nub $ fileLines - T.writeFile (configHome ++ "/hbro/queue.old") file - T.writeFile (configHome ++ "/hbro/queue") file' + 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 :: IO String -popBack = do - configHome <- getEnv "XDG_CONFIG_HOME" - file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\_error -> return T.empty) +popBack :: String -> IO String +popBack bookmarksFile = do + file <- catch (T.readFile bookmarksFile) (\_error -> return T.empty) if file == T.empty then return "" @@ -72,8 +57,8 @@ 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' + T.writeFile (bookmarksFile ++ ".old") file + T.writeFile bookmarksFile file' return $ T.unpack (head $ reverse fileLines) diff --git a/Hbro/Extra/Clipboard.hs b/Hbro/Extra/Clipboard.hs --- a/Hbro/Extra/Clipboard.hs +++ b/Hbro/Extra/Clipboard.hs @@ -1,54 +1,21 @@ module Hbro.Extra.Clipboard where -- {{{ Imports -import Hbro.Core -import Hbro.Types -import Hbro.Util +--import Hbro.Core +--import Hbro.Types +--import Hbro.Util -import Graphics.UI.Gtk.Abstract.Widget import Graphics.UI.Gtk.General.Clipboard -import Graphics.UI.Gtk.WebKit.WebView - -import System.Process -- }}} -- | Copy current URI in clipboard. -copyUri :: Browser -> IO () -copyUri browser = do - getUri <- webViewGetUri (mWebView $ mGUI browser) - primaryClip <- widgetGetClipboard (mWindow $ mGUI browser) selectionPrimary - - case getUri of - Just u -> clipboardSetText primaryClip u - _ -> return () - --- | Copy current page title in clipboard. -copyTitle :: Browser -> IO () -copyTitle browser = do - getTitle <- webViewGetTitle (mWebView $ mGUI browser) - primaryClip <- widgetGetClipboard (mWindow $ mGUI browser) selectionPrimary - - case getTitle of - Just t -> clipboardSetText primaryClip t - _ -> return () - --- | Load URI from clipboard. -loadURIFromClipboard :: Browser -> IO () -loadURIFromClipboard browser = do - primaryClip <- widgetGetClipboard (mWindow $ mGUI browser) selectionPrimary - - _ <- clipboardRequestText primaryClip $ \x -> case x of - Just uri -> putStrLn ("Loading URI from clipboard: " ++ uri) >> loadURI uri browser - _ -> putStrLn "Loading URI from clipboard: empty clipboard." - return () - --- | Load URI from clipboard in a new instance of the browser. -newInstanceFromClipboard :: Browser -> IO () -newInstanceFromClipboard browser = do - primaryClip <- widgetGetClipboard (mWindow $ mGUI browser) selectionPrimary - - _ <- clipboardRequestText primaryClip $ \x -> case x of - Just uri -> putStrLn ("Loading URI from clipboard in new instance: " ++ uri) >> spawn (proc "hbro" ["-u", uri]) - _ -> putStrLn "Loading URI from clipboard in new instance: empty clipboard." - return () +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 --- a/Hbro/Extra/History.hs +++ b/Hbro/Extra/History.hs @@ -1,49 +1,44 @@ module Hbro.Extra.History where -- {{{ Imports -import Hbro.Core -import Hbro.Types +--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.Environment -import System.Exit import System.Locale -import System.Process -- }}} -- | -addToHistory :: String -> String -> IO () -addToHistory uri title = do +add :: FilePath -> String -> String -> IO () +add historyFile uri title = do now <- getCurrentTime - configHome <- getEnv "XDG_CONFIG_HOME" let time = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" now - appendFile (configHome ++ "/hbro/history") $ time ++ " " ++ uri ++ " " ++ title ++ "\n" + appendFile historyFile $ time ++ " " ++ uri ++ " " ++ title ++ "\n" -- | -loadFromHistory :: Browser -> IO () -loadFromHistory browser = do - configHome <- getEnv "XDG_CONFIG_HOME" - file <- readFile $ configHome ++ "/hbro/history" +select :: FilePath -> [String] -> IO (Maybe String) +select historyFile dmenuOptions = do + file <- T.readFile historyFile - let file' = unlines . nub $ map reformat (sort . lines $ file) + let file' = T.unlines . nub $ map reformat (sort . T.lines $ file) - (code, result, e) <- readProcessWithExitCode "dmenu" ["-l", "10"] file' - return () - case (code, result) of - (ExitSuccess, r) -> - let - uri:_ = words $ r - in - loadURI uri browser - _ -> putStrLn e + selection <- dmenu dmenuOptions file' + case selection of + "" -> return Nothing + entry -> return $ Just ((head . words) entry) - where - reformat line = - let - _date:_time:uri:title = words line - in - unwords $ [uri] ++ title +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 --- a/Hbro/Extra/Misc.hs +++ b/Hbro/Extra/Misc.hs @@ -1,100 +1,80 @@ module Hbro.Extra.Misc where -- {{{ Imports -import Hbro.Core hiding(goBack, goForward) -import Hbro.Types +--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.Builder 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 -import System.Process -- }}} -- | Same as goBack function from Hbro.Core, -- but with feedback in case of failure. -goForward :: Browser -> IO () -goForward browser = 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 +--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 :: Browser -> IO () -goBackList browser = do +goBackList :: WebView -> [String] -> IO (Maybe String) +goBackList webView dmenuOptions = do list <- webViewGetBackForwardList webView n <- webBackForwardListGetBackLength list backList <- webBackForwardListGetBackListWithLimit list n dmenuList <- mapM itemToEntry backList - - (Just input, Just output, _, _) <- createProcess (proc "dmenu" ["-l", "10"]) { - std_in = CreatePipe, - std_out = CreatePipe } - - _ <- hPutStr input $ unlines (catMaybes dmenuList) - entry <- catch (hGetLine output) (\_error -> return "ERROR" ) + selection <- dmenu dmenuOptions $ (T.pack . unlines) (catMaybes dmenuList) - case words entry of - ["ERROR"] -> return () - uri:_ -> loadURI uri browser - _ -> return () - return () - where - webView = mWebView $ mGUI browser + 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 :: Browser -> IO () -goForwardList browser = do +goForwardList :: WebView -> [String] -> IO (Maybe String) +goForwardList webView dmenuOptions = do list <- webViewGetBackForwardList webView n <- webBackForwardListGetForwardLength list forwardList <- webBackForwardListGetForwardListWithLimit list n dmenuList <- mapM itemToEntry forwardList - - (Just input, Just output, _, _) <- createProcess (proc "dmenu" ["-l", "10"]) { - std_in = CreatePipe, - std_out = CreatePipe } - - _ <- hPutStr input $ unlines (catMaybes dmenuList) - entry <- catch (hGetLine output) (\_error -> return "ERROR" ) - - case words entry of - ["ERROR"] -> return () - uri:_ -> loadURI uri browser - _ -> return () - return () - where - webView = mWebView $ mGUI browser + selection <- dmenu dmenuOptions $ (T.pack . unlines) (catMaybes dmenuList) + + case words selection of + uri:_ -> return $ Just uri + _ -> return Nothing itemToEntry :: WebHistoryItem -> IO (Maybe String) @@ -108,8 +88,8 @@ -- | Toggle source display. -- Current implementation forces a refresh of current web page, which may be undesired. -toggleSourceMode :: Browser -> IO () -toggleSourceMode browser = do - currentMode <- webViewGetViewSourceMode (mWebView $ mGUI browser) - webViewSetViewSourceMode (mWebView $ mGUI browser) (not currentMode) - reload True browser +toggleSourceMode :: WebView -> IO () +toggleSourceMode webView = do + currentMode <- webViewGetViewSourceMode webView + webViewSetViewSourceMode webView (not currentMode) + webViewReload webView diff --git a/Hbro/Extra/Prompt.hs b/Hbro/Extra/Prompt.hs deleted file mode 100644 --- a/Hbro/Extra/Prompt.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Hbro.Extra.Prompt where - --- {{{ Imports -import Hbro.Core -import Hbro.Gui -import Hbro.Types - -import Graphics.UI.Gtk.Entry.Entry -import Graphics.UI.Gtk.WebKit.WebView --- }}} - - --- | Prompt for key words to search in current webpage. -promptFind :: Bool -> Bool -> Bool -> Browser -> IO () -promptFind caseSensitive forward wrap browser = - prompt "Search" "" True browser (\browser' -> do - keyWord <- entryGetText (mPromptEntry $ mGUI browser') - _found <- webViewSearchText (mWebView $ mGUI browser) keyWord caseSensitive forward wrap - return ()) - --- | Switch to next found key word. -findNext :: Bool -> Bool -> Bool -> Browser -> IO () -findNext caseSensitive forward wrap browser = do - keyWord <- entryGetText (mPromptEntry $ mGUI browser) - _found <- webViewSearchText (mWebView $ mGUI browser) keyWord caseSensitive forward wrap - return () - --- | Prompt for URI to open in current window. -promptURL :: Bool -> Browser -> IO () -promptURL False browser = - prompt "Open URL" "" False browser (\b -> do - uri <- entryGetText (mPromptEntry $ mGUI b) - loadURI uri b) -promptURL _ browser = do - uri <- webViewGetUri (mWebView $ mGUI browser) - case uri of - Just url -> prompt "Open URL" url False browser (\b -> do - u <- entryGetText (mPromptEntry $ mGUI b) - loadURI u b) - _ -> return () diff --git a/Hbro/Extra/Session.hs b/Hbro/Extra/Session.hs --- a/Hbro/Extra/Session.hs +++ b/Hbro/Extra/Session.hs @@ -1,7 +1,7 @@ module Hbro.Extra.Session where -- {{{ Imports -import Hbro.Types +--import Hbro.Types import Hbro.Util import qualified Data.Text as T @@ -18,13 +18,12 @@ import System.Process -- }}} -setupSession :: Browser -> IO () -setupSession browser = do +setupSession :: WebView -> String -> IO () +setupSession webView sessionDirectory = do pid <- getProcessID - configHome <- getEnv "XDG_CONFIG_HOME" - previousSession <- getDirectoryContents (configHome ++ "/hbro/") >>= return . (filter sessionFilesFilter) + previousSession <- getDirectoryContents sessionDirectory - let sessionFile = configHome ++ "/hbro/session." ++ show pid + let sessionFile = sessionDirectory ++ show pid _ <- on webView loadFinished $ \_ -> do uri <- webViewGetUri webView @@ -38,39 +37,24 @@ return () - where - webView = mWebView $ mGUI browser -sessionFilesFilter :: String -> Bool -sessionFilesFilter ('s':'e':'s':'s':'i':'o':'n':'.':_) = True -sessionFilesFilter _ = False - - -loadFromSession :: Browser -> IO () -loadFromSession browser = do - configHome <- getEnv "XDG_CONFIG_HOME" - previousSession <- getDirectoryContents (configHome ++ "/hbro/") >>= return . (filter sessionFilesFilter) - sessionURIs <- mapM getSessionURI previousSession - - - (Just input, Just output, _, _) <- createProcess (proc "dmenu" ["-l", "10"]) { - std_in = CreatePipe, - std_out = CreatePipe } - _ <- T.hPutStr input (T.unlines sessionURIs) - - uri <- catch (hGetLine output) (\_error -> return "ERROR" ) - - case uri of - "ERROR" -> return () - "" -> return () - u -> do - _ <- spawn (proc "hbro" ["-u", u]) - return () - -getSessionURI :: String -> IO T.Text -getSessionURI fileName = do - configHome <- getEnv "XDG_CONFIG_HOME" - file <- T.readFile $ configHome ++ "/hbro/" ++ fileName - - return $ (head . T.lines) file +--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 --- a/Hbro/Extra/StatusBar.hs +++ b/Hbro/Extra/StatusBar.hs @@ -1,7 +1,7 @@ module Hbro.Extra.StatusBar where -- {{{ Imports -import Hbro.Types +--import Hbro.Types import Hbro.Util import Control.Monad.Trans(liftIO) @@ -12,7 +12,6 @@ import Graphics.Rendering.Pango.Layout import Graphics.UI.Gtk.Abstract.Widget -import Graphics.UI.Gtk.Builder import Graphics.UI.Gtk.Display.Label import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.Misc.Adjustment @@ -25,12 +24,14 @@ -- }}} --- | Display scroll position in status bar. --- Needs a Label entitled "scroll" from the builder. -statusBarScrollPosition :: Browser -> IO () -statusBarScrollPosition browser = do - scrollLabel <- builderGetObject builder castToLabel "scroll" - adjustment <- scrolledWindowGetVAdjustment scrollWindow +-- | 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 @@ -39,40 +40,26 @@ page <- adjustmentGetPageSize adjustment case upper-lower-page of - 0 -> labelSetMarkup scrollLabel "ALL" - x -> labelSetMarkup scrollLabel $ show (round $ current/x*100) ++ "%" - - labelSetMarkup scrollLabel "0%" + 0 -> labelSetText widget "ALL" + x -> labelSetText widget $ show (round $ current/x*100) ++ "%" - where - builder = mBuilder (mGUI browser) - scrollWindow = mScrollWindow (mGUI browser) + labelSetText widget "0%" --- | Display current zoom level in status bar. --- Needs a Label entitled "zoom" from the builder. -statusBarZoomLevel :: Browser -> IO () -statusBarZoomLevel browser = do +-- | /!\ Doesn't work for now. +-- Write current zoom level in the given Label. +statusBarZoomLevel :: Label -> WebView -> IO () +statusBarZoomLevel widget webView = do zoomLevel <- webViewGetZoomLevel webView - zoomLabel <- builderGetObject builder castToLabel "zoom" - labelSetMarkup zoomLabel $ "x" ++ escapeMarkup (show zoomLevel) ++ "" - where - builder = mBuilder (mGUI browser) - webView = mWebView (mGUI browser) - + labelSetMarkup widget $ "x" ++ escapeMarkup (show zoomLevel) ++ "" -- | Display pressed keys in status bar. -- Needs a Label entitled "keys" from the builder. -statusBarPressedKeys :: Browser -> IO () -statusBarPressedKeys browser = - let - builder = mBuilder (mGUI browser) - webView = mWebView (mGUI browser) - in do - keysLabel <- builderGetObject builder castToLabel "keys" - labelSetAttributes keysLabel [ +statusBarPressedKeys :: Label -> WebView -> IO () +statusBarPressedKeys widget webView = do + labelSetAttributes widget [ AttrForeground {paStart = 0, paEnd = -1, paColor = Color 0 65535 0} ] @@ -82,61 +69,53 @@ let keyString = keyToString value case (keyString, modifiers) of - (Just k, []) -> liftIO $ labelSetText keysLabel k - (Just k, m) -> liftIO $ labelSetText keysLabel (show m ++ k) + (Just k, []) -> liftIO $ labelSetText widget k + (Just k, m) -> liftIO $ labelSetText widget (show m ++ k) _ -> return () return False return () --- | Display load progress in status bar. --- Needs a Label entitled "progress" from the builder. -statusBarLoadProgress :: Browser -> IO () -statusBarLoadProgress browser = - let - builder = mBuilder (mGUI browser) - webView = mWebView (mGUI browser) - in do - progressLabel <- builderGetObject builder castToLabel "progress" +-- | Write current load progress in the given Label. +statusBarLoadProgress :: Label -> WebView -> IO () +statusBarLoadProgress widget webView = do -- Load started _ <- on webView loadStarted $ \_ -> do - labelSetAttributes progressLabel [ + labelSetAttributes widget [ AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0} ] - labelSetText progressLabel "0%" + labelSetText widget "0%" -- Progress changed _ <- on webView progressChanged $ \progress' -> do - labelSetAttributes progressLabel [ + labelSetAttributes widget [ AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 65535 0} ] - labelSetText progressLabel $ show progress' ++ "%" + labelSetText widget $ show progress' ++ "%" -- Load finished _ <- on webView loadFinished $ \_ -> do - labelSetAttributes progressLabel [ + labelSetAttributes widget [ AttrForeground {paStart = 0, paEnd = -1, paColor = Color 0 65535 0} ] - labelSetText progressLabel "100%" + labelSetText widget "100%" -- Error _ <- on webView loadError $ \_ _ _ -> do - labelSetAttributes progressLabel [ + labelSetAttributes widget [ AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0} ] - labelSetText progressLabel "ERROR" + labelSetText widget "ERROR" return False return () --- | Display current URI, or the destination of a hovered link, in the status bar. --- Needs a Label named "uri" from the builder. -statusBarURI :: Browser -> IO () -statusBarURI browser = do - uriLabel <- builderGetObject builder castToLabel "uri" +-- | 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 ()) (\x -> setURILabel x uriLabel) getUri + maybe (return ()) (flip setURILabel widget) getUri -- Hovering link _ <- on webView hoveringOverLink $ \_title hoveredUri -> do @@ -146,21 +125,19 @@ (_, Just u) -> u (_, _) -> "ERROR" - setURILabel uri uriLabel + setURILabel uri widget return () where - builder = mBuilder (mGUI browser) - webView = mWebView (mGUI browser) 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 + 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 diff --git a/Hbro/Gui.hs b/Hbro/Gui.hs --- a/Hbro/Gui.hs +++ b/Hbro/Gui.hs @@ -1,23 +1,34 @@ {-# LANGUAGE DoRec #-} -module Hbro.Gui where +module Hbro.Gui ( + initGUI, + showWebInspector, + prompt, + promptIncremental, + toggleVisibility +) where -- {{{ Imports import Hbro.Types -import Control.Monad.Trans(liftIO) +import Control.Monad +import Control.Monad.Trans import Graphics.Rendering.Pango.Enums import Graphics.UI.Gtk.Abstract.Container +import Graphics.UI.Gtk.Abstract.Box import Graphics.UI.Gtk.Abstract.Widget import Graphics.UI.Gtk.Builder import Graphics.UI.Gtk.Display.Label import Graphics.UI.Gtk.Entry.Editable import Graphics.UI.Gtk.Entry.Entry -import Graphics.UI.Gtk.General.General +import qualified Graphics.UI.Gtk.General.General as GTK import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.Layout.HBox +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.Windows.Window @@ -27,185 +38,218 @@ -- }}} --- | Load GUI from XML file -loadGUI :: String -> IO GUI -loadGUI xmlPath = do +initGUI :: FilePath -> [AttrOp WebSettings] -> IO GUI +initGUI xmlPath settings = do whenNormal $ putStr ("Loading GUI from " ++ xmlPath ++ "... ") + void GTK.initGUI -- Load XML builder <- builderNew builderAddFromFile builder xmlPath + +-- Init components + (webView, sWindow) <- initWebView builder settings + (window, wBox) <- initWindow builder webView + promptBar <- initPromptBar builder + statusBar <- initStatusBar builder + inspectorWindow <- initWebInspector webView wBox + +-- Show window + widgetShowAll window + widgetHide (mBox promptBar) + + whenNormal $ putStrLn "Done." + return $ GUI window inspectorWindow sWindow webView promptBar statusBar builder --- Init main web view - webView <- webViewNew +initWebView :: Builder -> [AttrOp WebSettings] -> IO (WebView, ScrolledWindow) +initWebView builder settings = do + webView <- webViewNew + webSettings <- webSettingsNew + + set webSettings settings + set webView [ widgetCanDefault := True ] - _ <- on webView closeWebView $ do - mainQuit - return False + _ <- on webView closeWebView $ GTK.mainQuit >> return False + webViewSetWebSettings webView webSettings + +-- 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 () + return webView + + window <- builderGetObject builder castToScrolledWindow "webViewParent" + containerAdd window webView + scrolledWindowSetPolicy window PolicyNever PolicyNever + + return (webView, window) --- Load main window - window <- builderGetObject builder castToWindow "mainWindow" +initWindow :: Builder -> WebView -> IO (Window, VBox) +initWindow builder webView = do + window <- builderGetObject builder castToWindow "mainWindow" windowSetDefault window $ Just webView - - scrollWindow <- builderGetObject builder castToScrolledWindow "webViewParent" - containerAdd scrollWindow webView - scrolledWindowSetPolicy scrollWindow PolicyNever PolicyNever + windowSetDefaultSize window 800 600 + widgetModifyBg window StateNormal (Color 0 0 10000) + _ <- onDestroy window GTK.mainQuit + + box <- builderGetObject builder castToVBox "windowBox" + + return (window, box) - promptLabel <- builderGetObject builder castToLabel "promptDescription" - labelSetAttributes promptLabel [ +initPromptBar :: Builder -> IO PromptBar +initPromptBar builder = do + label <- builderGetObject builder castToLabel "promptDescription" + labelSetAttributes label [ AttrStyle {paStart = 0, paEnd = -1, paStyle = StyleItalic}, AttrWeight {paStart = 0, paEnd = -1, paWeight = WeightBold} ] - promptEntry <- builderGetObject builder castToEntry "promptEntry" - statusBox <- builderGetObject builder castToHBox "statusBox" - --- Create web inspector's window - inspector <- webViewGetInspector webView - inspectorWindow <- initWebInspector inspector + entry <- builderGetObject builder castToEntry "promptEntry" + box <- builderGetObject builder castToHBox "promptBox" - whenNormal $ putStrLn "Done." - return $ GUI window inspectorWindow scrollWindow webView promptLabel promptEntry statusBox builder - + return $ PromptBar box label entry + +initStatusBar :: Builder -> IO HBox +initStatusBar builder = builderGetObject builder castToHBox "statusBox" + -- {{{ Web inspector -initWebInspector :: WebInspector -> IO (Window) -initWebInspector inspector = do +initWebInspector :: WebView -> VBox -> IO (Window) +initWebInspector webView windowBox = do + inspector <- webViewGetInspector webView inspectorWindow <- windowNew set inspectorWindow [ windowTitle := "hbro | Web inspector" ] _ <- on inspector inspectWebView $ \_ -> do - webView <- webViewNew - containerAdd inspectorWindow webView - return webView + view <- webViewNew + containerAdd inspectorWindow view + return view _ <- on inspector showWindow $ do widgetShowAll inspectorWindow return True - -- TODO: when does this signal happen ?! +-- TODO: when does this signal happen ?! --_ <- on inspector finished $ return () --- _ <- on inspector attachWindow $ do --- getWebView <- webInspectorGetWebView inspector --- case getWebView of --- Just webView -> do widgetHide (mInspectorWindow gui) --- containerRemove (mInspectorWindow gui) webView --- widgetSetSizeRequest webView (-1) 250 --- boxPackEnd (mWindowBox gui) webView PackNatural 0 --- widgetShow webView --- return True --- _ -> return False +-- Attach inspector to browser's main window + _ <- on inspector attachWindow $ do + getWebView <- webInspectorGetWebView inspector + case getWebView of + Just view -> do + widgetHide inspectorWindow + containerRemove inspectorWindow view + widgetSetSizeRequest view (-1) 250 + boxPackEnd windowBox view PackNatural 0 + widgetShow view + return True + _ -> return False --- _ <- on inspector detachWindow $ do --- getWebView <- webInspectorGetWebView inspector --- _ <- case getWebView of --- Just webView -> do containerRemove (mWindowBox gui) webView --- containerAdd (mInspectorWindow gui) webView --- widgetShowAll (mInspectorWindow gui) --- return True --- _ -> return False +-- Detach inspector in a distinct window + _ <- on inspector detachWindow $ do + getWebView <- webInspectorGetWebView inspector + _ <- case getWebView of + Just view -> do + containerRemove windowBox view + containerAdd inspectorWindow view + widgetShowAll inspectorWindow + return True + _ -> return False --- widgetShowAll (mInspectorWindow gui) --- return True + widgetShowAll inspectorWindow + return True return inspectorWindow -- | Show web inspector for current webpage. -showWebInspector :: Browser -> IO () -showWebInspector browser = do - inspector <- webViewGetInspector (mWebView $ mGUI browser) +showWebInspector :: WebView -> IO () +showWebInspector webView = do + inspector <- webViewGetInspector webView webInspectorInspectCoordinates inspector 0 0 - -- }}} -- {{{ Prompt --- | Show or hide the prompt bar (label + entry). -showPrompt :: Bool -> Browser -> IO () -showPrompt toShow browser = case toShow of - False -> do widgetHide (mPromptLabel $ mGUI browser) - widgetHide (mPromptEntry $ mGUI browser) - _ -> do widgetShow (mPromptLabel $ mGUI browser) - widgetShow (mPromptEntry $ mGUI browser) +openPrompt :: PromptBar -> String -> String -> IO () +openPrompt _promptBar@PromptBar {mBox = promptBox, mDescription = description, mEntry = entry} newDescription defaultText = do + labelSetText description newDescription + entrySetText entry defaultText + + widgetShow promptBox + widgetGrabFocus entry + editableSetPosition entry (-1) + +-- | Open prompt bar with given description and default value, +-- and register a callback to trigger at validation. +prompt :: String -> String -> (String -> IO ()) -> PromptBar -> IO () +prompt l d = prompt' l d False --- | Show the prompt bar label and default text. --- As the user validates its entry, the given callback is executed. -prompt :: String -> String -> Bool -> Browser -> (Browser -> IO ()) -> IO () -prompt label defaultText incremental browser callback = let - promptLabel = (mPromptLabel $ mGUI browser) - promptEntry = (mPromptEntry $ mGUI browser) - webView = (mWebView $ mGUI browser) - in do - -- Fill prompt - labelSetText promptLabel label - entrySetText promptEntry defaultText - - -- Focus on prompt - showPrompt True browser - widgetGrabFocus promptEntry - editableSetPosition promptEntry (-1) +-- | Same as 'prompt', but callback is triggered for each change in prompt's entry. +promptIncremental :: String -> String -> (String -> IO ()) -> PromptBar -> IO () +promptIncremental l d = prompt' l d True - -- Register callback - case incremental of - True -> do - id1 <- on promptEntry editableChanged $ - liftIO $ callback browser - rec id2 <- on promptEntry keyPressEvent $ do - key <- eventKeyName - - case key of - "Return" -> do - liftIO $ showPrompt False browser - liftIO $ signalDisconnect id1 - liftIO $ signalDisconnect id2 - liftIO $ widgetGrabFocus webView - "Escape" -> do - liftIO $ showPrompt False browser - liftIO $ signalDisconnect id1 - liftIO $ signalDisconnect id2 - liftIO $ widgetGrabFocus webView - _ -> return () - return False - return () +prompt' :: String -> String -> Bool -> (String -> IO ()) -> PromptBar -> IO () +prompt' description defaultText incremental callback promptBar = do + openPrompt promptBar description defaultText - _ -> do - rec id <- on promptEntry keyPressEvent $ do - key <- eventKeyName +-- Register callback + case incremental of + True -> do + id1 <- on entry editableChanged $ entryGetText entry >>= callback + rec id2 <- on entry keyPressEvent $ do + key <- eventKeyName + + case key of + "Return" -> liftIO $ do + widgetHide promptBox + signalDisconnect id1 + signalDisconnect id2 + --widgetGrabFocus webView + "Escape" -> liftIO $ do + widgetHide promptBox + signalDisconnect id1 + signalDisconnect id2 + --widgetGrabFocus webView + _ -> return () + return False + return () - case key of - "Return" -> do - liftIO $ showPrompt False browser - liftIO $ callback browser - liftIO $ signalDisconnect id - liftIO $ widgetGrabFocus webView - "Escape" -> do - liftIO $ showPrompt False browser - liftIO $ signalDisconnect id - liftIO $ widgetGrabFocus webView - _ -> return () - return False + _ -> do + rec id <- on entry keyPressEvent $ do + key <- eventKeyName - return () + case key of + "Return" -> liftIO $ do + widgetHide promptBox + entryGetText entry >>= callback + signalDisconnect id + --widgetGrabFocus webView + "Escape" -> liftIO $ do + widgetHide promptBox + signalDisconnect id + --widgetGrabFocus webView + _ -> return () + return False + + return () + where + promptBox = mBox promptBar + entry = mEntry promptBar + --webView = (mWebView . mGUI) environment -- }}} -- {{{ Util --- | Toggle statusbar's visibility -toggleStatusBar :: Browser -> IO () -toggleStatusBar browser = do - visibility <- get (mStatusBox $ mGUI browser) widgetVisible +-- | Toggle a widget's visibility (provided for convenience). +toggleVisibility :: WidgetClass a => a -> IO () +toggleVisibility widget = do + visibility <- get widget widgetVisible case visibility of - False -> widgetShow (mStatusBox $ mGUI browser) - _ -> widgetHide (mStatusBox $ mGUI browser) - - --- | Set the window fullscreen -fullscreen :: Browser -> IO () -fullscreen browser = windowFullscreen (mWindow $ mGUI browser) - --- | Restore the window from fullscreen -unfullscreen :: Browser -> IO () -unfullscreen browser = windowUnfullscreen (mWindow $ mGUI browser) + False -> widgetShow widget + _ -> widgetHide widget -- }}} diff --git a/Hbro/Main.hs b/Hbro/Main.hs --- a/Hbro/Main.hs +++ b/Hbro/Main.hs @@ -5,15 +5,20 @@ import Hbro.Types import Paths_hbro + +import System.Directory -- }}} +-- | Default main function provided as example. main :: IO () main = do + home <- getHomeDirectory + tmp <- getTemporaryDirectory uiFile <- getDataFileName "examples/ui.xml" -- putStrLn "[WARNING] You are running the default configuration which provides hardly no feature." --- putStrLn $ "[WARNING] You should copy the example configuration files hbro.hs and ui.xml in " ++ configHome ++ "/hbro and start hacking them." +-- putStrLn "[WARNING] You should copy the example configuration files hbro.hs and ui.xml in ~/.config/hbro/hbro and start hacking them." - hbro defaultConfiguration { + launchHbro $ (defaultConfig home tmp) { mUIFile = uiFile } diff --git a/Hbro/Socket.hs b/Hbro/Socket.hs --- a/Hbro/Socket.hs +++ b/Hbro/Socket.hs @@ -1,8 +1,12 @@ module Hbro.Socket where -- {{{ Imports +import Hbro.Util import Hbro.Types +import Control.Monad +import Control.Monad.Reader + import Data.ByteString.Char8 (pack, unpack) import qualified Data.Map as Map @@ -15,20 +19,17 @@ -- | Create a response socket to listen for commands. -- Loops on listenToSocket until "Quit" command is received. -createRepSocket :: Context -> String -> Browser -> IO () -createRepSocket context socketURI browser = do - whenNormal $ putStrLn ("Listening socket at " ++ socketURI) +openRepSocket :: Context -> String -> (Socket Rep -> IO ()) -> IO () +openRepSocket context socketURI listen = do + whenNormal $ putStrLn ("Opening socket at " ++ socketURI) withSocket context Rep $ \repSocket -> do bind repSocket socketURI - listenToSocket repSocket commandsList browser - where - commandsList = Map.fromList (defaultCommandsList ++ (mCommands $ mConfiguration browser)) - + listen repSocket -- | Listen for incoming requests from response socket. -- Parse received commands and feed the corresponding callback, if any. -listenToSocket :: Socket Rep -> CommandsMap -> Browser -> IO () -listenToSocket repSocket commands browser = do +listenToCommands :: Environment -> CommandsMap -> Socket Rep -> IO () +listenToCommands environment commands repSocket = do message <- receive repSocket [] let message' = unpack message @@ -36,71 +37,96 @@ -- Empty command [] -> send repSocket (pack "ERROR Unknown command") [] -- Exit command - ["Quit"] -> send repSocket (pack "OK") [] + ["QUIT"] -> do + whenLoud $ putStrLn "Receiving QUIT command" + send repSocket (pack "OK") [] -- Valid command command:arguments -> do whenLoud $ putStrLn ("Receiving command: " ++ message') case Map.lookup command commands of - Just callback -> callback arguments repSocket browser + Just callback -> callback arguments repSocket environment _ -> send repSocket (pack "ERROR Unknown command") [] - listenToSocket repSocket commands browser + listenToCommands environment commands repSocket + +-- | 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 + +-- | 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 + +-- | 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) + -- | List of default supported requests. defaultCommandsList :: CommandsList defaultCommandsList = [ -- Get information - ("getUri", \_arguments repSocket browser -> do + ("GET_URI", \_arguments repSocket browser -> liftIO $ do getUri <- postGUISync $ webViewGetUri (mWebView $ mGUI browser) case getUri of Just uri -> send repSocket (pack uri) [] _ -> send repSocket (pack "ERROR No URL opened") [] ), - ("getTitle", \_arguments repSocket browser -> do + ("GET_TITLE", \_arguments repSocket browser -> liftIO $ do getTitle <- postGUISync $ webViewGetTitle (mWebView $ mGUI browser) case getTitle of Just title -> send repSocket (pack title) [] _ -> send repSocket (pack "ERROR No title") [] ), - ("getFaviconUri", \_arguments repSocket browser -> do + ("GET_FAVICON_URI", \_arguments repSocket browser -> liftIO $ do getUri <- postGUISync $ webViewGetIconUri (mWebView $ mGUI browser) case getUri of Just uri -> send repSocket (pack uri) [] _ -> send repSocket (pack "ERROR No favicon uri") [] ), - ("getLoadProgress", \_arguments repSocket browser -> do + ("GET_LOAD_PROGRESS", \_arguments repSocket browser -> liftIO $ do progress <- postGUISync $ webViewGetProgress (mWebView $ mGUI browser) send repSocket (pack (show progress)) [] ), -- Trigger actions - ("loadUri", \arguments repSocket browser -> case arguments of + ("LOAD_URI", \arguments repSocket browser -> liftIO $ case arguments of uri:_ -> do postGUIAsync $ webViewLoadUri (mWebView $ mGUI browser) uri send repSocket (pack "OK") [] _ -> send repSocket (pack "ERROR: argument needed.") [] ), - ("stopLoading", \_arguments repSocket browser -> do + ("STOP_LOADING", \_arguments repSocket browser -> liftIO $do postGUIAsync $ webViewStopLoading (mWebView $ mGUI browser) send repSocket (pack "OK") [] ), - ("reload", \_arguments repSocket browser -> do + ("RELOAD", \_arguments repSocket browser -> liftIO $ do postGUIAsync $ webViewReload (mWebView $ mGUI browser) send repSocket (pack "OK") [] ), - ("goBack", \_arguments repSocket browser -> do + ("GO_BACK", \_arguments repSocket browser -> liftIO $ do postGUIAsync $ webViewGoBack (mWebView $ mGUI browser) send repSocket (pack "OK") [] ), - ("goForward", \_arguments repSocket browser -> do + ("GO_FORWARD", \_arguments repSocket browser -> liftIO $ do postGUIAsync $ webViewGoForward (mWebView $ mGUI browser) send repSocket (pack "OK") [] ), - ("zoomIn", \_arguments repSocket browser -> do + ("ZOOM_IN", \_arguments repSocket browser -> liftIO $ do postGUIAsync $ webViewZoomIn (mWebView $ mGUI browser) send repSocket (pack "OK") [] ), - ("zoomOut", \_arguments repSocket browser -> do + ("ZOOM_OUT", \_arguments repSocket browser -> liftIO $ do postGUIAsync $ webViewZoomOut (mWebView $ mGUI browser) send repSocket (pack "OK") [] ) ] diff --git a/Hbro/Types.hs b/Hbro/Types.hs --- a/Hbro/Types.hs +++ b/Hbro/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} module Hbro.Types where -- {{{ Imports @@ -15,14 +16,16 @@ import Graphics.UI.Gtk.Windows.Window import System.Console.CmdArgs +import System.Glib.Attributes import System.ZMQ -- }}} -data Browser = Browser { - mOptions :: CliOptions, -- ^ Commandline options - mConfiguration :: Configuration, -- ^ Custom configuration provided by user - mGUI :: GUI -- ^ Graphical widgets +data Environment = Environment { + mOptions :: CliOptions, -- ^ Commandline options + mConfig :: Config, -- ^ Configuration parameters (constants) provided by user + mGUI :: GUI, -- ^ Graphical widgets + mContext :: Context -- ^ } data CliOptions = CliOptions { @@ -30,15 +33,16 @@ } deriving (Data, Typeable, Show, Eq) -data Configuration = Configuration { - mHomePage :: String, -- ^ Startup page - mSocketDir :: String, -- ^ Directory where 0MQ will be created ("/tmp" for example) - mUIFile :: String, -- ^ Path to XML file describing UI (used by GtkBuilder) - mKeys :: KeysList, -- ^ List of keybindings - mWebSettings :: IO WebSettings, -- ^ Web settings provided by webkit (see Webkit::WebSettings documentation) - mSetup :: Browser -> IO (), -- ^ Custom startup instructions - mCommands :: CommandsList, -- ^ Custom commands to use with IPC sockets - mError :: Maybe String -- ^ Error +data Config = {-forall a.-} Config { + mHomePage :: String, -- ^ Startup page + mSocketDir :: String, -- ^ Directory where 0MQ will be created ("/tmp" for example) + mUIFile :: String, -- ^ Path to XML file describing UI (used by GtkBuilder) + mKeys :: Environment -> KeysList, -- ^ List of keybindings + mWebSettings :: [AttrOp WebSettings], -- ^ WebSettings' attributes to use with webkit (see Webkit.WebSettings documentation) + mSetup :: Environment -> IO (), -- ^ Custom startup instructions + mCommands :: CommandsList, -- ^ Custom commands to use with IPC sockets + mError :: Maybe String -- ^ Error + --mCustom :: a } data GUI = GUI { @@ -46,13 +50,18 @@ mInspectorWindow :: Window, -- ^ WebInspector window mScrollWindow :: ScrolledWindow, -- ^ ScrolledWindow containing the webview mWebView :: WebView, -- ^ Browser's webview - mPromptLabel :: Label, -- ^ Description of current prompt - mPromptEntry :: Entry, -- ^ Prompt entry + mPromptBar :: PromptBar, mStatusBox :: HBox, -- ^ Status bar's horizontal box mBuilder :: Builder -- ^ Builder object created from XML file } +data PromptBar = PromptBar { + mBox :: HBox, + mDescription :: Label, -- ^ Description of current prompt + mEntry :: Entry -- ^ Prompt entry +} + -- | List of bound keys -- All callbacks are fed with the Browser instance -- Note 1 : for modifiers, lists are used for convenience purposes, @@ -60,7 +69,7 @@ -- so that order and repetition don't matter -- Note 2 : for printable characters accessed via the shift modifier, -- you do have to include Shift in modifiers list -type KeysList = [(([Modifier], String), (Browser -> IO ()))] +type KeysList = [(([Modifier], String), IO ())] -type CommandsList = [(String, ([String] -> Socket Rep -> Browser -> IO ()))] -type CommandsMap = Map String ([String] -> Socket Rep -> Browser -> IO ()) +type CommandsList = [(String, ([String] -> Socket Rep -> Environment -> IO ()))] +type CommandsMap = Map String ([String] -> Socket Rep -> Environment -> IO ()) diff --git a/Hbro/Util.hs b/Hbro/Util.hs --- a/Hbro/Util.hs +++ b/Hbro/Util.hs @@ -3,8 +3,14 @@ -- {{{ Imports import Hbro.Types +--import Control.Monad.Reader +import Control.Monad + +import Data.List import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.IO as T import Graphics.UI.Gtk.Display.Label import Graphics.UI.Gtk.Gdk.EventM @@ -12,6 +18,9 @@ import Graphics.UI.Gtk.General.General --import System.Console.CmdArgs (whenLoud, whenNormal) +import qualified System.Info as Sys +import System.IO +import System.Posix.Process import System.Process -- }}} @@ -47,13 +56,13 @@ -- | Convert key bindings list to a map. -- Calls importKeyBindings'. -importKeyBindings :: [(([Modifier], String), (Browser -> IO ()))] -> Map.Map (Set.Set Modifier, String) (Browser -> IO ()) +importKeyBindings :: KeysList -> Map.Map (Set.Set Modifier, String) (IO ()) importKeyBindings list = Map.fromList $ importKeyBindings' list -- | Convert modifiers list to modifiers sets. -- The order of modifiers in key bindings don't matter. -- Called by importKeyBindings. -importKeyBindings' :: [(([Modifier], String), (Browser -> IO ()))] -> [((Set.Set Modifier, String), (Browser -> IO ()))] +importKeyBindings' :: KeysList -> [((Set.Set Modifier, String), IO ())] importKeyBindings' (((a, b), c):t) = ((Set.fromList a, b), c):(importKeyBindings' t) importKeyBindings' _ = [] -- }}} @@ -67,9 +76,12 @@ -- | 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 :: 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 () +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 () -- }}} -- | Set a temporary markup text to a label that disappears after some delay. @@ -79,3 +91,31 @@ timeoutAdd clear delay where clear = labelSetMarkup label "" >> return False + + +getAllProcessIDs :: IO [FilePath] +getAllProcessIDs = do + (_, pids, _) <- readProcessWithExitCode "pidof" ["hbro"] [] + (_, pids', _) <- readProcessWithExitCode "pidof" ["hbro-" ++ Sys.os ++ "-" ++ Sys.arch] [] + myPid <- getProcessID + + return $ delete (show myPid) . nub . words $ pids ++ " " ++ pids' + + + + +(>>?) :: (a -> IO ()) -> Maybe a -> IO () +(>>?) = maybe (return ()) + + + +dmenu :: [String] -> T.Text -> IO String +dmenu options input = do + (in_, out, err, pid) <- runInteractiveProcess "dmenu" options Nothing Nothing + T.hPutStr in_ input + hClose in_ + + output <- catch (hGetLine out) $ \_error -> return [] + + hClose out >> hClose err >> (void $ waitForProcess pid) + return output diff --git a/examples/hbro.hs b/examples/hbro.hs --- a/examples/hbro.hs +++ b/examples/hbro.hs @@ -1,16 +1,17 @@ module Main where -- {{{ Imports -import Hbro.Core hiding(goBack, goForward) +import Hbro.Core import qualified Hbro.Extra.Bookmarks as Bookmarks import qualified Hbro.Extra.BookmarksQueue as Queue import Hbro.Extra.Clipboard -import Hbro.Extra.History +import qualified Hbro.Extra.History as History import Hbro.Extra.Misc import Hbro.Extra.Prompt import Hbro.Extra.Session import Hbro.Extra.StatusBar import Hbro.Gui +import Hbro.Socket import Hbro.Types import Hbro.Util @@ -29,6 +30,7 @@ import Graphics.UI.Gtk.WebKit.WebView import Graphics.UI.Gtk.Windows.Window +import System.Directory import System.Environment import System.Glib.Attributes import System.Glib.Signals @@ -36,180 +38,198 @@ import System.Process -- }}} - +-- | Main function, basically launches hbro. main :: IO () main = do - configHome <- getEnv "XDG_CONFIG_HOME" + home <- getHomeDirectory + tmp <- getTemporaryDirectory + launchHbro $ myConfig home tmp - -- See Hbro.Types.Configuration documentation for fields description - -- Commented out fields indicate default values - hbro defaultConfiguration { - --mSocketDir = "/tmp/", - mUIFile = configHome ++ "/hbro/ui.xml", - --mHomePage = "https://www.google.com", - mKeys = myKeys, - mWebSettings = myWebSettings, - mSetup = mySetup - } +-- | Application parameters. +-- See Hbro.Types.Parameters documentation for fields description. +-- Commented out fields indicate default values. +myConfig :: String -> String -> Config +myConfig home tmp = (defaultConfig home tmp) { + --mSocketDir = tmp, + mUIFile = home ++ "/.config/hbro/ui.xml", + mHomePage = "https://duckduckgo.com", + mKeys = myKeys home, + mWebSettings = myWebSettings, + mSetup = mySetup +} + +myHistoryFile :: FilePath -> FilePath +myHistoryFile home = home ++ "/.config/hbro/history" + +myBookmarksFile :: FilePath -> FilePath +myBookmarksFile home = home ++ "/.config/hbro/bookmarks" + + -- {{{ Keys -- Note that this example is suited for an azerty keyboard. -myKeys :: KeysList -myKeys = generalKeys ++ bookmarksKeys ++ historyKeys ++ sessionKeys - -generalKeys :: KeysList -generalKeys = [ +myKeys :: FilePath -> Environment -> KeysList +myKeys home environment@Environment {mGUI = gui, mConfig = config, mContext = context} = let + window = mWindow gui + webView = mWebView gui + scrolledWindow = mScrollWindow gui + statusBox = mStatusBox gui + promptBar = mPromptBar gui + promptEntry = mEntry promptBar + bookmarksFile = myBookmarksFile home + historyFile = myHistoryFile home + socketDir = mSocketDir config + in + [ -- ((modifiers, key), callback) -- Browse - (([Control], ""), goBack), - (([Control], ""), goForward), - (([Alt], ""), goBackList), - (([Alt], ""), goForwardList), - (([Control], "s"), stopLoading), - (([], ""), reload True), - (([Shift], ""), reload False), - (([Control], "r"), reload True), - (([Control, Shift], "R"), reload False), - (([Control], "^"), horizontalHome), - (([Control], "$"), horizontalEnd), - (([Control], ""), verticalHome), - (([Control], ""), verticalEnd), - (([Alt], ""), goHome), - (([Control], "g"), promptGoogle), + (([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)) promptBar), -- Display - (([Control, Shift], "+"), zoomIn), - (([Control], "-"), zoomOut), - (([], ""), fullscreen), - (([], ""), unfullscreen), - (([Control], "b"), toggleStatusBar), - (([Control], "u"), toggleSourceMode), + (([Control, Shift], "+"), webViewZoomIn webView), + (([Control], "-"), webViewZoomOut webView), + (([], ""), windowFullscreen window), + (([], ""), windowUnfullscreen window), + (([Control], "b"), toggleVisibility statusBox), + (([Control], "u"), toggleSourceMode webView), -- Prompt - (([Control], "o"), promptURL False), - (([Control, Shift], "O"), promptURL True), + (([Control], "o"), prompt "Open URL " "" (loadURI webView) promptBar), + (([Control, Shift], "O"), webViewGetUri webView >>= maybe (return ()) (\uri -> prompt "Open URL " uri (loadURI webView) promptBar)), -- Search - (([Shift], "/"), promptFind False True True), - (([Control], "f"), promptFind False True True), - (([Shift], "?"), promptFind False False True), - (([Control], "n"), findNext False True True), - (([Control, Shift], "N"), findNext False False True), + (([Shift], "/"), promptIncremental "Search " "" (\word -> webViewSearchText webView word False True True >> return ()) promptBar), + (([Control], "f"), promptIncremental "Search " "" (\word -> webViewSearchText webView word False True True >> return ()) promptBar), + (([Shift], "?"), promptIncremental "Search " "" (\word -> webViewSearchText webView word False False True >> return ()) promptBar), + (([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"), copyUri), - (([Control, Shift], "Y"), copyTitle), - (([Control], "p"), loadURIFromClipboard), - (([Control, Shift], "P"), newInstanceFromClipboard), + (([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])), -- Others - (([Control], "i"), showWebInspector), - (([Alt], "p"), printPage), - (([Control], "t"), \_ -> newInstance), - (([Control], "w"), \_ -> mainQuit) - ] - -bookmarksKeys :: KeysList -bookmarksKeys = [ - (([Control], "d"), Bookmarks.addWithTags), - (([Control, Shift], "D"), Bookmarks.addAllWithTags), - (([Alt], "d"), \_ -> Bookmarks.deleteWithTag), - (([Control], "l"), Bookmarks.load), - (([Control, Shift], "L"), \_ -> Bookmarks.loadWithTag), - (([Control], "q"), Queue.append), - (([Alt], "q"), \b -> do - uri <- Queue.popFront - loadURI uri b) - ] + (([Control], "i"), showWebInspector webView), + (([Alt], "p"), printPage webView), + (([Control], "t"), spawn "hbro" []), + (([Control], "w"), mainQuit), -historyKeys :: KeysList -historyKeys = [ - (([Control], "h"), loadFromHistory) - ] +-- Bookmarks + (([Control], "d"), webViewGetUri webView >>= maybe (return ()) (\uri -> prompt "Bookmark with tags:" "" (\tags -> Bookmarks.add bookmarksFile uri (words tags)) promptBar)), + (([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 ()) promptBar), + (([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), -sessionKeys :: KeysList -sessionKeys = [ - (([Alt], "l"), loadFromSession) +-- History + (([Control], "h"), History.select historyFile ["-l", "10"] >>= maybe (return ()) (loadURI webView)) + +-- Session + --(([Alt], "l"), loadFromSession ["-l", "10"]) ] -- }}} -- {{{ Web settings -- Commented lines correspond to default values -myWebSettings :: IO WebSettings -myWebSettings = do - settings <- webSettingsNew - set settings [ - --SETTING DEFAULT 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 := True, - --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 - ] - return settings +myWebSettings :: [AttrOp WebSettings] +myWebSettings = [ + --SETTING DEFAULT 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 :: Browser -> IO () -mySetup browser = +mySetup :: Environment -> IO () +mySetup environment@Environment {mGUI = gui} = let - builder = mBuilder (mGUI browser) - webView = mWebView (mGUI browser) - scrollWindow = mScrollWindow (mGUI browser) - window = mWindow (mGUI browser) - in do - -- Default background (basically for status bar) - widgetModifyBg window StateNormal (Color 0 0 10000) + builder = mBuilder gui + webView = mWebView gui + scrolledWindow = mScrollWindow gui + window = mWindow gui + in do + -- Scroll position in status bar + scrollLabel <- builderGetObject builder castToLabel "scroll" + setupScrollWidget scrollLabel scrolledWindow + + -- Zoom level in status bar + zoomLabel <- builderGetObject builder castToLabel "zoom" + statusBarZoomLevel zoomLabel webView - -- Status bar - statusBarScrollPosition browser - statusBarZoomLevel browser - statusBarPressedKeys browser - statusBarLoadProgress browser - statusBarURI browser + -- Pressed keys in status bar + keysLabel <- builderGetObject builder castToLabel "keys" + statusBarPressedKeys keysLabel webView + + -- Load progress in status bar + progressLabel <- builderGetObject builder castToLabel "progress" + statusBarLoadProgress progressLabel webView + + -- Current URI in status bar + uriLabel <- builderGetObject builder castToLabel "uri" + statusBarURI uriLabel webView -- Session manager - setupSession browser + --setupSession browser _ <- on webView titleChanged $ \_ title -> set window [ windowTitle := ("hbro | " ++ title)] - -- Download requests _ <- on webView downloadRequested $ \download -> do uri <- downloadGetUri download @@ -232,16 +252,15 @@ (True, _) -> webPolicyDecisionUse policyDecision >> return True _ -> webPolicyDecisionDownload policyDecision >> return True - -- History handler + home <- getHomeDirectory _ <- on webView loadFinished $ \_ -> do uri <- webViewGetUri webView title <- webViewGetTitle webView case (uri, title) of - (Just uri', Just title') -> addToHistory uri' title' + (Just uri', Just title') -> History.add (myHistoryFile home) uri' title' _ -> return () - -- On navigating to a new URI -- Return True to forbid navigation, False to allow _ <- on webView navigationPolicyDecisionRequested $ \_ request action policyDecision -> do @@ -256,17 +275,16 @@ Just uri -> case mouseButton of 1 -> return False -- Left button - 2 -> spawn (proc "hbro" ["-u", uri]) >> putStrLn uri >> return True -- Middle 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 $ proc "hbro" ["-u", uri]) >> putStrLn uri + Just uri -> (spawn "hbro" ["-u", uri]) >> putStrLn uri _ -> putStrLn "ERROR: wrong URI given, unable to open window." return True @@ -280,15 +298,7 @@ myDownload :: String -> String -> IO () myDownload uri name = do - home <- getEnv "HOME" - --spawn $ proc "wget [uri, "-O", home ++ "/" ++ name] - --spawn $ proc "axel [uri, "-o", home ++ "/" ++ name] - spawn $ proc "aria2c" [uri, "-d", home ++ "/", "-o", name] - -promptGoogle :: Browser -> IO () -promptGoogle browser = - prompt "Google search" "" False browser (\browser' -> do - keyWords <- entryGetText (mPromptEntry $ mGUI browser') - loadURI ("https://www.google.com/search?q=" ++ keyWords) browser' - return ()) - + home <- getHomeDirectory + --spawn "wget [uri, "-O", home ++ "/" ++ name] + --spawn "axel [uri, "-o", home ++ "/" ++ name] + spawn "aria2c" [uri, "-d", home ++ "/", "-o", name] diff --git a/hbro.cabal b/hbro.cabal --- a/hbro.cabal +++ b/hbro.cabal @@ -1,5 +1,5 @@ Name: hbro -Version: 0.6.8.2 +Version: 0.7.0.0 Synopsis: A minimal KISS compliant browser -- Description: Homepage: http://projects.haskell.org/hbro/ @@ -48,7 +48,6 @@ Hbro.Extra.Clipboard, Hbro.Extra.History, Hbro.Extra.Misc, - Hbro.Extra.Prompt, Hbro.Extra.Session, Hbro.Extra.StatusBar, Hbro.Gui, @@ -62,12 +61,8 @@ Build-depends: hbro, base == 4.*, - glib, - gtk, - mtl, - process, - unix, - webkit + directory, + mtl Main-is: Main.hs Hs-Source-Dirs: Hbro Ghc-options: -Wall -threaded