diff --git a/Hbro/Config.hs b/Hbro/Config.hs --- a/Hbro/Config.hs +++ b/Hbro/Config.hs @@ -10,7 +10,6 @@ -- }}} --- {{{ Dyre showError :: Configuration -> String -> Configuration showError configuration message = configuration { mError = Just message } @@ -21,8 +20,6 @@ Dyre.realMain = realMain, Dyre.ghcOpts = ["-threaded"] } --- }}} - -- | Default configuration. -- Does quite nothing. diff --git a/Hbro/Core.hs b/Hbro/Core.hs --- a/Hbro/Core.hs +++ b/Hbro/Core.hs @@ -19,13 +19,15 @@ 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 Graphics.UI.Gtk.WebKit.WebDataSource import Graphics.UI.Gtk.WebKit.WebFrame +import Graphics.UI.Gtk.WebKit.WebView import Network.URL import System.Console.CmdArgs import System.Glib.Signals +import System.Process import System.Posix.Process import qualified System.ZMQ as ZMQ -- }}} @@ -49,51 +51,46 @@ -- {{{ Entry point -- | Entry point for the application. --- Parse arguments and step down in favour of initBrowser. --- Print configuration error, if any. +-- Parse commandline arguments, print configuration error if any, +-- create browser and load homepage. realMain :: Configuration -> IO () -realMain configuration = do +realMain config = do +-- Parse commandline arguments options <- getOptions - case (mError configuration) of - Just e -> putStrLn e - _ -> return () - - initBrowser configuration options --- }}} - +-- Print configuration error, if any + maybe (return ()) putStrLn (mError config) --- {{{ Main function --- | Application's main function. --- Create browser and load homepage. -initBrowser :: Configuration -> CliOptions -> IO () -initBrowser configuration options = do - -- Initialize browser +-- Initialize GUI _ <- initGUI - gui <- loadGUI (mUIFile configuration) - let browser = Browser options configuration gui + gui <- loadGUI (mUIFile config) + let browser = Browser options config gui let webView = mWebView gui + let window = mWindow gui - -- Load additionnal settings from configuration - settings <- mWebSettings configuration - webViewSetWebSettings webView settings - (mSetup configuration) browser + _ <- onDestroy window mainQuit + widgetShowAll window + showPrompt False browser - -- Load homepage - goHome browser +-- Load additionnal settings from configuration + settings <- mWebSettings config + webViewSetWebSettings webView settings + (mSetup config) browser - -- Load key bindings - let keyBindings = importKeyBindings (mKeys configuration) +-- Load key bindings + let keyBindings = importKeyBindings (mKeys config) - -- On new window request +-- On new window request _ <- on webView createWebView $ \frame -> do newUri <- webFrameGetUri frame - putStrLn "NEW WINDOW" case newUri of - Just uri -> webViewLoadUri webView uri + Just uri -> do + whenLoud $ putStrLn ("Requesting new window: " ++ uri ++ "...") + webViewLoadUri webView uri Nothing -> return () return webView +-- Manage keys _ <- after webView keyPressEvent $ do value <- eventKeyVal modifiers <- eventModifier @@ -104,58 +101,71 @@ Just "" -> liftIO $ showPrompt False browser Just string -> do case Map.lookup (Set.fromList modifiers, string) keyBindings of - Just callback -> liftIO $ callback browser - _ -> liftIO $ putStrLn string + Just callback -> do + liftIO $ callback browser + liftIO $ whenLoud (putStrLn $ "Key pressed: " ++ show modifiers ++ string ++ " (mapped)") + _ -> liftIO $ whenLoud (putStrLn $ "Key pressed: " ++ show modifiers ++ string ++ " (unmapped)") _ -> return () return False - -- Connect and show. - _ <- onDestroy (mWindow gui) mainQuit - widgetShowAll (mWindow gui) - showPrompt False browser +-- Load homepage + case (mURI options) of + Just uri -> do + webViewLoadUri webView uri + whenLoud $ putStrLn ("Loading " ++ uri ++ "...") + _ -> goHome browser - -- Initialize IPC socket +-- Initialize IPC socket pid <- getProcessID - let socketURI = "ipc://" ++ (mSocketDir configuration) ++ "/hbro." ++ show pid - putStrLn $ "Listening socket " ++ socketURI + let socketURI = "ipc://" ++ (mSocketDir config) ++ "/hbro." ++ show pid + --timeoutAdd (putStrLn "OK" >> return True) 2000 + ZMQ.withContext 1 $ \context -> do _ <- forkIO $ createRepSocket context socketURI browser - mainGUI + 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") [] - reply <- ZMQ.receive reqSocket [] + _ <- ZMQ.receive reqSocket [] return () + + whenNormal $ putStrLn "Exiting..." -- }}} --- {{{ Browse --- | Load homepage (retrieved from commandline options or configuration file) +-- {{{ Browsing functions +-- | Load homepage (set from configuration file). goHome :: Browser -> IO () -goHome browser = case (mURI $ mOptions browser) of - Just uri -> loadURI uri browser - _ -> loadURI (mHomePage $ mConfiguration browser) browser +goHome browser = do + whenLoud $ putStrLn ("Loading homepage: " ++ uri) + loadURI uri browser + where + uri = mHomePage $ mConfiguration browser --- | Wrapper around webViewGoBack function +-- | Wrapper around webViewGoBack function, provided for convenience. goBack :: Browser -> IO () goBack browser = webViewGoBack (mWebView $ mGUI browser) --- | Wrapper around webViewGoForward function +-- | Wrapper around webViewGoForward function, provided for convenience. goForward :: Browser -> IO () goForward browser = webViewGoForward (mWebView $ mGUI browser) --- | Wrapper around webViewStopLoading function +-- | Wrapper around webViewStopLoading function, provided for convenience. stopLoading :: Browser -> IO () stopLoading browser = webViewStopLoading (mWebView $ mGUI browser) --- | Wrapper around webViewReload{BypassCache} --- If boolean argument is False, it bypasses the cache -reload :: Bool -> Browser -> IO() +-- | 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) @@ -163,26 +173,28 @@ loadURI :: String -> Browser -> IO () loadURI url browser = case importURL url of - Just url' -> loadURI' url' browser - _ -> return () + Just url' -> do + whenLoud $ putStrLn ("Loading URI: " ++ url) + loadURI' url' browser + _ -> return () -- | Backend function for loadURI. loadURI' :: URL -> Browser -> IO () loadURI' url@URL {url_type = Absolute _} browser = webViewLoadUri (mWebView $ mGUI browser) (exportURL url) loadURI' url@URL {url_type = HostRelative} browser = - webViewLoadUri (mWebView $ mGUI browser) ("file://" ++ exportURL url) >> putStrLn (show url) + webViewLoadUri (mWebView $ mGUI browser) ("file://" ++ exportURL url) loadURI' url@URL {url_type = _} browser = - webViewLoadUri (mWebView $ mGUI browser) ("http://" ++ exportURL url) >> print url + webViewLoadUri (mWebView $ mGUI browser) ("http://" ++ exportURL url) -- }}} -- {{{ Zoom --- | Wrapper around webViewZoomIn function +-- | Wrapper around webViewZoomIn function, provided for convenience. zoomIn :: Browser -> IO () -zoomIn browser = webViewZoomIn (mWebView $ mGUI browser) +zoomIn browser = webViewZoomIn (mWebView $ mGUI browser) --- | Wrapper around webViewZoomOut function +-- | Wrapper around webViewZoomOut function, provided for convenience. zoomOut :: Browser -> IO () zoomOut browser = webViewZoomOut (mWebView $ mGUI browser) -- }}} @@ -213,7 +225,7 @@ 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) @@ -221,7 +233,7 @@ 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) @@ -232,13 +244,29 @@ -- | Spawn a new instance of the browser. -newWindow :: Browser -> IO () -newWindow browser = runExternalCommand "hbro" +newInstance :: IO () +newInstance = spawn (proc "hbro" []) -- | Execute a javascript file on current webpage. executeJSFile :: String -> Browser -> IO () executeJSFile filePath browser = do + whenNormal $ putStrLn ("Executing Javascript file: " ++ filePath) script <- readFile filePath let script' = unwords . map (\line -> line ++ "\n") . lines $ script webViewExecuteScript (mWebView $ mGUI browser) 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 + 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 @@ -65,9 +65,9 @@ connect reqSocket socketURI send reqSocket (B.pack "getUri") [] - uri <- receive reqSocket [] + uri' <- receive reqSocket [] - add (B.unpack uri) (words tags) + add (B.unpack uri') (words tags) ) _ <- mapM bookmarkPID pidsList @@ -89,7 +89,7 @@ std_out = CreatePipe } _ <- T.hPutStr input file' - entry <- catch (hGetLine output) (\e -> return "ERROR" ) + entry <- catch (hGetLine output) (\_error -> return "ERROR" ) case reverse . words $ entry of ["ERROR"] -> return () uri:_ -> loadURI uri browser @@ -104,8 +104,8 @@ tags' = sort $ map (\tag -> T.snoc (T.cons '[' tag) ']') tags -- | -loadWithTag :: Browser -> IO () -loadWithTag browser = do +loadWithTag :: IO () +loadWithTag = do -- Read bookmarks file configHome <- getEnv "XDG_CONFIG_HOME" file <- T.readFile $ configHome ++ "/hbro/bookmarks" @@ -119,12 +119,12 @@ std_out = CreatePipe } _ <- T.hPutStr input list - tag <- catch (hGetLine output) (\e -> return "ERROR" ) + tag <- catch (hGetLine output) (\_error -> return "ERROR" ) case tag of "ERROR" -> return () "" -> return () t -> do - _ <- mapM (\uri -> runExternalCommand ("hbro -u \"" ++ (T.unpack uri) ++ "\"")) uris + _ <- mapM (\uri -> spawn (proc "hbro" ["-u", (T.unpack uri)])) uris return () where file' = filter (tagFilter $ T.pack t) (T.lines file) @@ -132,14 +132,14 @@ -- tagFilter :: T.Text -> T.Text -> Bool -tagFilter tag line = let uri:tags = T.words line in case (intersect [tag] tags) of - [t] -> True - _ -> False +tagFilter tag line = let _uri:tags = T.words line in case (intersect [tag] tags) of + [_tag] -> True + _ -> False -- | -deleteWithTag :: Browser -> IO () -deleteWithTag browser = do +deleteWithTag :: IO () +deleteWithTag = do configHome <- getEnv "XDG_CONFIG_HOME" file <- T.readFile $ configHome ++ "/hbro/bookmarks" @@ -150,11 +150,11 @@ std_out = CreatePipe } _ <- T.hPutStr input tagsList - tag <- catch (hGetLine output) (\e -> return "ERROR" ) + tag <- catch (hGetLine output) (\_error -> return "ERROR" ) case tag of "ERROR" -> return () "" -> return () - t -> do + _ -> do T.writeFile (configHome ++ "/hbro/bookmarks.old") file T.writeFile (configHome ++ "/hbro/bookmarks") file' return () diff --git a/Hbro/Extra/BookmarksQueue.hs b/Hbro/Extra/BookmarksQueue.hs --- a/Hbro/Extra/BookmarksQueue.hs +++ b/Hbro/Extra/BookmarksQueue.hs @@ -28,7 +28,7 @@ push browser = do uri <- webViewGetUri (mWebView $ mGUI browser) configHome <- getEnv "XDG_CONFIG_HOME" - file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\e -> return T.empty) + file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\_error -> return T.empty) case uri of Just u -> @@ -44,10 +44,10 @@ _ -> return () -- | Return the first URI from the queue, while removing it. -popFront :: Browser -> IO String -popFront browser = do +popFront :: IO String +popFront = do configHome <- getEnv "XDG_CONFIG_HOME" - file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\e -> return T.empty) + file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\_error -> return T.empty) if file == T.empty then return "" @@ -61,10 +61,10 @@ return $ T.unpack (head fileLines) -- | Return the last URI from the queue, while removing it. -popBack :: Browser -> IO String -popBack browser = do +popBack :: IO String +popBack = do configHome <- getEnv "XDG_CONFIG_HOME" - file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\e -> return T.empty) + file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\_error -> return T.empty) if file == T.empty then return "" diff --git a/Hbro/Extra/Clipboard.hs b/Hbro/Extra/Clipboard.hs --- a/Hbro/Extra/Clipboard.hs +++ b/Hbro/Extra/Clipboard.hs @@ -3,10 +3,13 @@ -- {{{ Imports 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 -- }}} @@ -38,4 +41,14 @@ _ <- 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 () diff --git a/Hbro/Extra/History.hs b/Hbro/Extra/History.hs --- a/Hbro/Extra/History.hs +++ b/Hbro/Extra/History.hs @@ -28,7 +28,7 @@ configHome <- getEnv "XDG_CONFIG_HOME" file <- readFile $ configHome ++ "/hbro/history" - let file' = unlines . sort . nub $ map reformat (lines file) + let file' = unlines . nub $ map reformat (sort . lines $ file) (code, result, e) <- readProcessWithExitCode "dmenu" ["-l", "10"] file' return () @@ -43,7 +43,7 @@ where reformat line = let - date:time:uri:title = words line + _date:_time:uri:title = words line in unwords $ [uri] ++ title diff --git a/Hbro/Extra/Prompt.hs b/Hbro/Extra/Prompt.hs --- a/Hbro/Extra/Prompt.hs +++ b/Hbro/Extra/Prompt.hs @@ -15,14 +15,14 @@ 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 + _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 + _found <- webViewSearchText (mWebView $ mGUI browser) keyWord caseSensitive forward wrap return () -- | Prompt for URI to open in current window. diff --git a/Hbro/Extra/Session.hs b/Hbro/Extra/Session.hs new file mode 100644 --- /dev/null +++ b/Hbro/Extra/Session.hs @@ -0,0 +1,76 @@ +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 :: Browser -> IO () +setupSession browser = do + pid <- getProcessID + configHome <- getEnv "XDG_CONFIG_HOME" + previousSession <- getDirectoryContents (configHome ++ "/hbro/") >>= return . (filter sessionFilesFilter) + + let sessionFile = configHome ++ "/hbro/session." ++ 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 () + + 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 + diff --git a/Hbro/Extra/StatusBar.hs b/Hbro/Extra/StatusBar.hs --- a/Hbro/Extra/StatusBar.hs +++ b/Hbro/Extra/StatusBar.hs @@ -17,26 +17,20 @@ import Graphics.UI.Gtk.WebKit.WebView import System.Glib.Signals - ---import System.Process -- }}} -- | Display scroll position in status bar. --- Needs a Label intitled "scroll" from the builder. +-- Needs a Label entitled "scroll" from the builder. statusBarScrollPosition :: Browser -> IO () -statusBarScrollPosition browser = - let - builder = mBuilder (mGUI browser) - scrollWindow = mScrollWindow (mGUI browser) - in do - scrollLabel <- builderGetObject builder castToLabel "scroll" +statusBarScrollPosition browser = do + scrollLabel <- builderGetObject builder castToLabel "scroll" + adjustment <- scrolledWindowGetVAdjustment scrollWindow - adjustment <- scrolledWindowGetVAdjustment scrollWindow _ <- onValueChanged adjustment $ do - current <- adjustmentGetValue adjustment - lower <- adjustmentGetLower adjustment - upper <- adjustmentGetUpper adjustment + current <- adjustmentGetValue adjustment + lower <- adjustmentGetLower adjustment + upper <- adjustmentGetUpper adjustment page <- adjustmentGetPageSize adjustment case upper-lower-page of @@ -44,9 +38,12 @@ x -> labelSetMarkup scrollLabel $ show (round $ current/x*100) ++ "%" labelSetMarkup scrollLabel "0%" - --return () + where + builder = mBuilder (mGUI browser) + scrollWindow = mScrollWindow (mGUI browser) + -- | Display pressed keys in status bar. -- Needs a Label intitled "keys" from the builder. statusBarPressedKeys :: Browser -> IO () @@ -97,25 +94,32 @@ -- | Display current URI, or the destination of a hovered link, in the status bar. --- Needs a Label intitled "uri" from the builder. +-- Needs a Label named "uri" from the builder. statusBarURI :: Browser -> IO () -statusBarURI browser = - let - builder = mBuilder (mGUI browser) - webView = mWebView (mGUI browser) - in do +statusBarURI browser = do uriLabel <- builderGetObject builder castToLabel "uri" _ <- on webView loadCommitted $ \_ -> do getUri <- (webViewGetUri webView) - case getUri of - Just uri -> labelSetMarkup uriLabel $ "" ++ escapeMarkup uri ++ "" - _ -> labelSetMarkup uriLabel "ERROR" + let (color, uri) = case getUri of + Just (u@('h':'t':'t':'p':'s':_)) -> ("orange", u) + Just u -> ("gray", u) + _ -> ("red", "ERROR") + + labelSetMarkup uriLabel $ "" ++ escapeMarkup uri ++ "" - _ <- on webView hoveringOverLink $ \title hoveredUri -> do + _ <- on webView hoveringOverLink $ \_title hoveredUri -> do getUri <- (webViewGetUri webView) - case (hoveredUri, getUri) of - (Just u, _) -> labelSetMarkup uriLabel $ "" ++ escapeMarkup u ++ "" - (_, Just u) -> labelSetMarkup uriLabel $ "" ++ escapeMarkup u ++ "" - _ -> putStrLn "FIXME" + let (color, uri) = case (hoveredUri, getUri) of + (Just u, _) -> ("#5555ff", u) + (_, Just (u@('h':'t':'t':'p':'s':_))) -> ("orange", u) + (_, Just u) -> ("white", u) + _ -> ("red", "ERROR") + + labelSetMarkup uriLabel $ "" ++ escapeMarkup uri ++ "" return () + + where + builder = mBuilder (mGUI browser) + webView = mWebView (mGUI browser) + diff --git a/Hbro/Gui.hs b/Hbro/Gui.hs --- a/Hbro/Gui.hs +++ b/Hbro/Gui.hs @@ -6,7 +6,6 @@ import Control.Monad.Trans(liftIO) ---import Graphics.UI.Gtk.Abstract.Misc import Graphics.UI.Gtk.Abstract.Container import Graphics.UI.Gtk.Abstract.Widget import Graphics.UI.Gtk.Builder @@ -21,6 +20,7 @@ import Graphics.UI.Gtk.WebKit.WebView import Graphics.UI.Gtk.Windows.Window +import System.Console.CmdArgs (whenNormal, whenLoud) import System.Glib.Attributes import System.Glib.Signals -- }}} @@ -29,20 +29,22 @@ -- | Load GUI from XML file loadGUI :: String -> IO GUI loadGUI xmlPath = do + whenNormal $ putStrLn ("Loading GUI from " ++ xmlPath ++ "...") + +-- builder <- builderNew builderAddFromFile builder xmlPath - -- Init main web view +-- Init main web view webView <- webViewNew set webView [ widgetCanDefault := True ] _ <- on webView closeWebView $ do mainQuit - return True + return False - -- Load main window +-- Load main window window <- builderGetObject builder castToWindow "mainWindow" windowSetDefault window (Just webView) - set window [ windowTitle := "hbro" ] scrollWindow <- builderGetObject builder castToScrolledWindow "webViewParent" containerAdd scrollWindow webView @@ -54,10 +56,11 @@ promptEntry <- builderGetObject builder castToEntry "promptEntry" statusBox <- builderGetObject builder castToHBox "statusBox" - -- Create web inspector's window +-- Create web inspector's window inspector <- webViewGetInspector webView inspectorWindow <- initWebInspector inspector - + + whenLoud $ putStrLn "Done." return $ GUI window inspectorWindow scrollWindow webView promptLabel promptEntry statusBox builder @@ -131,16 +134,16 @@ promptEntry = (mPromptEntry $ mGUI browser) webView = (mWebView $ mGUI browser) in do - -- Fill prompt + -- Fill prompt labelSetText promptLabel label entrySetText promptEntry defaultText - -- Focus on prompt + -- Focus on prompt showPrompt True browser widgetGrabFocus promptEntry editableSetPosition promptEntry (-1) - -- Register callback + -- Register callback case incremental of True -> do id1 <- on promptEntry editableChanged $ diff --git a/Hbro/Socket.hs b/Hbro/Socket.hs --- a/Hbro/Socket.hs +++ b/Hbro/Socket.hs @@ -9,13 +9,15 @@ import Graphics.UI.Gtk.General.General import Graphics.UI.Gtk.WebKit.WebView +import System.Console.CmdArgs (whenNormal, whenLoud) import System.ZMQ -- }}} -- | 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 = +createRepSocket context socketURI browser = do + whenNormal $ putStrLn ("Listening socket at " ++ socketURI) withSocket context Rep $ \repSocket -> do bind repSocket socketURI listenToSocket repSocket commandsList browser @@ -27,11 +29,17 @@ -- Parse received commands and feed the corresponding callback, if any. listenToSocket :: Socket Rep -> CommandsMap -> Browser -> IO () listenToSocket repSocket commands browser = do - message <- receive repSocket [] - case words (unpack message) of - [] -> send repSocket (pack "ERROR Unknown command") [] + message <- receive repSocket [] + let message' = unpack message + + case words message' of + -- Empty command + [] -> send repSocket (pack "ERROR Unknown command") [] + -- Exit command ["Quit"] -> 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 _ -> send repSocket (pack "ERROR Unknown command") [] @@ -42,25 +50,25 @@ defaultCommandsList :: CommandsList defaultCommandsList = [ -- Get information - ("getUri", \arguments repSocket browser -> do + ("getUri", \_arguments repSocket browser -> 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 + ("getTitle", \_arguments repSocket browser -> 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 + ("getFaviconUri", \_arguments repSocket browser -> 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 + ("getLoadProgress", \_arguments repSocket browser -> do progress <- postGUISync $ webViewGetProgress (mWebView $ mGUI browser) send repSocket (pack (show progress)) [] ), @@ -72,30 +80,28 @@ send repSocket (pack "OK") [] _ -> send repSocket (pack "ERROR: argument needed.") [] ), - ("stopLoading", \arguments repSocket browser -> do + ("stopLoading", \_arguments repSocket browser -> do postGUIAsync $ webViewStopLoading (mWebView $ mGUI browser) send repSocket (pack "OK") [] ), - ("reload", \arguments repSocket browser -> do + ("reload", \_arguments repSocket browser -> do postGUIAsync $ webViewReload (mWebView $ mGUI browser) send repSocket (pack "OK") [] ), - ("goBack", \arguments repSocket browser -> do + ("goBack", \_arguments repSocket browser -> do postGUIAsync $ webViewGoBack (mWebView $ mGUI browser) send repSocket (pack "OK") [] ), - ("goForward", \arguments repSocket browser -> do + ("goForward", \_arguments repSocket browser -> do postGUIAsync $ webViewGoForward (mWebView $ mGUI browser) send repSocket (pack "OK") [] ), - ("zoomIn", \arguments repSocket browser -> do + ("zoomIn", \_arguments repSocket browser -> do postGUIAsync $ webViewZoomIn (mWebView $ mGUI browser) send repSocket (pack "OK") [] ), - ("zoomOut", \arguments repSocket browser -> do + ("zoomOut", \_arguments repSocket browser -> do postGUIAsync $ webViewZoomOut (mWebView $ mGUI browser) send repSocket (pack "OK") [] ) ] - - diff --git a/Hbro/Util.hs b/Hbro/Util.hs --- a/Hbro/Util.hs +++ b/Hbro/Util.hs @@ -6,7 +6,12 @@ import qualified Data.Map as Map import qualified Data.Set as Set -import Graphics.UI.Gtk +import Graphics.UI.Gtk.Display.Label +import Graphics.UI.Gtk.Gdk.EventM +import Graphics.UI.Gtk.Gdk.Keys +import Graphics.UI.Gtk.General.General + +--import System.Console.CmdArgs (whenLoud, whenNormal) import System.Process -- }}} @@ -62,6 +67,15 @@ -- | 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` -runExternalCommand :: String -> IO () -runExternalCommand command = runCommand' $ "nohup " ++ command ++ " > /dev/null 2>&1" +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. +labelSetMarkupTemporary :: Label -> String -> Int -> IO HandlerId +labelSetMarkupTemporary label text delay = do + labelSetMarkup label text + timeoutAdd clear delay + where + clear = labelSetMarkup label "" >> return False diff --git a/examples/hbro.hs b/examples/hbro.hs --- a/examples/hbro.hs +++ b/examples/hbro.hs @@ -9,12 +9,15 @@ import Hbro.Extra.History import Hbro.Extra.Misc import Hbro.Extra.Prompt +import Hbro.Extra.Session import Hbro.Extra.StatusBar import Hbro.Gui 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 @@ -54,14 +57,14 @@ -- {{{ Keys -- Note that this example is suited for an azerty keyboard. myKeys :: KeysList -myKeys = generalKeys ++ bookmarksKeys ++ historyKeys +myKeys = generalKeys ++ bookmarksKeys ++ historyKeys ++ sessionKeys generalKeys :: KeysList generalKeys = [ -- ((modifiers, key), callback) - -- Browse +-- Browse (([Control], ""), goBack), - (([Shift], ""), goForward), + (([Control], ""), goForward), (([Control], "s"), stopLoading), (([], ""), reload True), (([Shift], ""), reload False), @@ -74,7 +77,7 @@ (([Alt], ""), goHome), (([Control], "g"), promptGoogle), - -- Display +-- Display (([Control, Shift], "+"), zoomIn), (([Control], "-"), zoomOut), (([], ""), fullscreen), @@ -82,26 +85,27 @@ (([Control], "b"), toggleStatusBar), (([Control], "u"), toggleSourceMode), - -- Prompt +-- Prompt (([Control], "o"), promptURL False), (([Control, Shift], "O"), promptURL True), - -- Search +-- 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), - -- Copy/paste +-- Copy/paste (([Control], "y"), copyUri), (([Control, Shift], "Y"), copyTitle), (([Control], "p"), loadURIFromClipboard), + (([Control, Shift], "P"), newInstanceFromClipboard), - -- Others +-- Others (([Control], "i"), showWebInspector), (([Alt], "p"), printPage), - (([Control], "t"), newWindow), + (([Control], "t"), \_ -> newInstance), (([Control], "w"), \_ -> mainQuit) ] @@ -109,12 +113,12 @@ bookmarksKeys = [ (([Control], "d"), Bookmarks.addWithTags), (([Control, Shift], "D"), Bookmarks.addAllWithTags), - (([Alt], "d"), Bookmarks.deleteWithTag), + (([Alt], "d"), \_ -> Bookmarks.deleteWithTag), (([Control], "l"), Bookmarks.load), - (([Control, Shift], "L"), Bookmarks.loadWithTag), + (([Control, Shift], "L"), \_ -> Bookmarks.loadWithTag), (([Control], "q"), Queue.append), (([Alt], "q"), \b -> do - uri <- Queue.popFront b + uri <- Queue.popFront loadURI uri b) ] @@ -122,8 +126,12 @@ historyKeys = [ (([Control], "h"), loadFromHistory) ] --- }}} +sessionKeys :: KeysList +sessionKeys = [ + (([Alt], "l"), loadFromSession) + ] +-- }}} -- {{{ Web settings -- Commented lines correspond to default values @@ -175,7 +183,6 @@ return settings -- }}} - -- {{{ Setup mySetup :: Browser -> IO () mySetup browser = @@ -185,31 +192,37 @@ scrollWindow = mScrollWindow (mGUI browser) window = mWindow (mGUI browser) in do - -- Default background (for status bar) + -- Default background (basically for status bar) widgetModifyBg window StateNormal (Color 0 0 10000) - -- Status bar + -- Status bar statusBarScrollPosition browser statusBarPressedKeys browser statusBarLoadProgress browser statusBarURI browser + -- Session manager + setupSession browser + _ <- on webView titleChanged $ \_ title -> set window [ windowTitle := ("hbro | " ++ title)] - -- Download requests + -- Download requests _ <- on webView downloadRequested $ \download -> do uri <- downloadGetUri download name <- downloadGetSuggestedFilename download size <- downloadGetTotalSize download + feedbackLabel <- builderGetObject builder castToLabel "feedback" case (uri, name) of - (Just uri', Just name') -> myDownload uri' name' - _ -> return () + (Just uri', Just name') -> do + myDownload uri' name' + labelSetMarkupTemporary feedbackLabel "Download started" 5000 + _ -> labelSetMarkupTemporary feedbackLabel "Unable to download" 5000 return False - -- Per MIME actions + -- Per MIME actions _ <- on webView mimeTypePolicyDecisionRequested $ \_ request mimetype policyDecision -> do show <- webViewCanShowMimeType webView mimetype @@ -218,7 +231,7 @@ _ -> webPolicyDecisionDownload policyDecision >> return True - -- History handler + -- History handler _ <- on webView loadFinished $ \_ -> do uri <- webViewGetUri webView title <- webViewGetTitle webView @@ -227,8 +240,8 @@ _ -> return () - -- On navigating to a new URI - -- Return True to forbid navigation, False to allow + -- 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 @@ -241,22 +254,22 @@ Just uri -> case mouseButton of 1 -> return False -- Left button - 2 -> runExternalCommand ("hbro -u \"" ++ uri ++ "\"") >> return True -- Middle button + 2 -> spawn (proc "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 requesting new window _ <- on webView newWindowPolicyDecisionRequested $ \_ request action policyDecision -> do getUri <- networkRequestGetUri request case getUri of - Just uri -> runExternalCommand $ "hbro -u \"" ++ uri ++ "\"" + Just uri -> (spawn $ proc "hbro" ["-u", uri]) >> putStrLn uri _ -> putStrLn "ERROR: wrong URI given, unable to open window." return True - -- Favicon + -- Favicon --_ <- on webView iconLoaded $ \uri -> do something return () @@ -266,9 +279,9 @@ myDownload :: String -> String -> IO () myDownload uri name = do home <- getEnv "HOME" - --runExternalCommand $ "wget \"" ++ uri ++ "\" -O \"" ++ home ++ "/" ++ name ++ "\"" - --runExternalCommand $ "axel \"" ++ uri ++ "\" -o \"" ++ home ++ "/" ++ name ++ "\"" - runExternalCommand $ "aria2c \"" ++ uri ++ "\" -d " ++ home ++ "/ -o \"" ++ name ++ "\"" + --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 = diff --git a/examples/ui.xml b/examples/ui.xml --- a/examples/ui.xml +++ b/examples/ui.xml @@ -55,7 +55,7 @@ 0 - + @@ -73,6 +73,16 @@ False + + + + + GTK_PACK_END + False + False + + + diff --git a/hbro.cabal b/hbro.cabal --- a/hbro.cabal +++ b/hbro.cabal @@ -1,6 +1,6 @@ Name: hbro -Version: 0.6.7 -Synopsis: A suckless minimal KISSy browser +Version: 0.6.8 +Synopsis: A minimal KISS compliant browser -- Description: Homepage: http://projects.haskell.org/hbro/ Category: Browser,Web @@ -27,6 +27,7 @@ bytestring, cmdargs, containers, + directory, dyre, glib, gtk, @@ -49,6 +50,7 @@ Hbro.Extra.History, Hbro.Extra.Misc, Hbro.Extra.Prompt, + Hbro.Extra.Session, Hbro.Extra.StatusBar, Hbro.Gui, Hbro.Socket,