hbro 0.5.0 → 0.5.1
raw patch · 7 files changed
+292/−265 lines, 7 files
Files
- Hbro/Core.hs +73/−69
- Hbro/Gui.hs +63/−64
- Hbro/Socket.hs +14/−14
- Hbro/Types.hs +50/−0
- Hbro/Util.hs +11/−6
- examples/Main.hs +77/−110
- hbro.cabal +4/−2
Hbro/Core.hs view
@@ -1,9 +1,10 @@-{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} module Hbro.Core where -- {{{ Imports import Hbro.Gui import Hbro.Socket+import Hbro.Types import Hbro.Util import qualified Config.Dyre as Dyre@@ -18,49 +19,23 @@ import Graphics.UI.Gtk.Abstract.Widget import Graphics.UI.Gtk.General.General import Graphics.UI.Gtk.Gdk.EventM---import Graphics.UI.Gtk.WebKit.Download---import Graphics.UI.Gtk.WebKit.NetworkRequest import Graphics.UI.Gtk.WebKit.WebView import Graphics.UI.Gtk.WebKit.WebFrame import Graphics.UI.Gtk.WebKit.WebInspector-import Graphics.UI.Gtk.WebKit.WebSettings+--import Graphics.UI.Gtk.Windows.Window import Network.URL import Prelude import System.Console.CmdArgs---import System.Glib.Attributes import System.Glib.Signals import System.Posix.Process -- }}} --- {{{ Type definitions-data Browser = Browser {- mOptions :: CliOptions, -- ^ Commandline options- mGUI :: GUI -- ^ Graphical widgets-}--data Configuration = Configuration {- mHomePage :: String, -- ^ Startup page - mSocketDir :: String, -- ^ Path to socket directory ("/tmp" for example)- mUIFile :: String, -- ^ Path to XML file describing UI (used by GtkBuilder)- mKeyBindings :: KeyBindingsList, -- ^ List of keybindings- mWebSettings :: IO WebSettings, -- ^ Web settings- mAtStartUp :: GUI -> IO (), -- ^ Custom startup instructions- mError :: Maybe String -- ^ Error-}--type KeyBindingsList = [(([Modifier], String), (GUI -> IO ()))]--- }}}- -- {{{ Commandline options-data CliOptions = CliOptions {- mURI :: Maybe String-} deriving (Data, Typeable, Show, Eq)- cliOptions :: CliOptions cliOptions = CliOptions{- mURI = def &= help "URI to open at startup" &= explicit &= name "u" &= name "uri" &= typ "URI"+ mURI = def &= help "URI to open at start-up" &= explicit &= name "u" &= name "uri" &= typ "URI" } getOptions :: IO CliOptions@@ -94,25 +69,20 @@ -- Initialize browser _ <- initGUI gui <- loadGUI (mUIFile configuration)- --let browser = Browser options gui+ let browser = Browser options configuration gui+ let webView = mWebView gui -- Initialize IPC socket pid <- getProcessID- _ <- forkIO $ createReplySocket ("ipc://" ++ (mSocketDir configuration) ++ "/hbro." ++ show pid) gui+ _ <- forkIO $ createReplySocket ("ipc://" ++ (mSocketDir configuration) ++ "/hbro." ++ show pid) browser -- Load configuration settings <- mWebSettings configuration- webViewSetWebSettings (mWebView gui) settings-- -- Launch custom startup- (mAtStartUp configuration) gui-- -- Load url- let url = case (mURI options) of- Just x -> x- _ -> mHomePage configuration+ webViewSetWebSettings webView settings+ (mAtStartUp configuration) browser - loadURL url gui+ -- Load homepage+ goHome browser -- Load key bindings let keyBindings = importKeyBindings (mKeyBindings configuration)@@ -120,13 +90,13 @@ -- On new window request --newWindowWebView <- webViewNew- _ <- on (mWebView gui) createWebView $ \frame -> do+ _ <- on webView createWebView $ \frame -> do newUri <- webFrameGetUri frame case newUri of- Just uri -> webViewLoadUri (mWebView gui) uri+ Just uri -> webViewLoadUri webView uri --Just uri -> runExternalCommand $ "hbro " ++ uri Nothing -> return ()- return (mWebView gui)+ return webView -- return newWindowWebView -- _ <- on newWindowWebView loadCommitted $ \frame -> do@@ -137,11 +107,11 @@ -- Web inspector- inspector <- webViewGetInspector (mWebView gui)+ inspector <- webViewGetInspector webView _ <- on inspector inspectWebView $ \_ -> do- webView <- webViewNew- containerAdd (mInspectorWindow gui) webView- return webView+ inspectorWebView <- webViewNew+ containerAdd (mInspectorWindow gui) inspectorWebView+ return inspectorWebView _ <- on inspector showWindow $ do widgetShowAll (mInspectorWindow gui)@@ -170,12 +140,12 @@ -- return True -- _ -> return False - widgetShowAll (mInspectorWindow gui)- return True+-- widgetShowAll (mInspectorWindow gui)+-- return True -- Key bindings--- imContext <- get (mWebView gui) webViewImContext--- _ <- on (mWebView gui) keyPressEvent $ do+-- imContext <- get webView webViewImContext+-- _ <- on webView keyPressEvent $ do -- value <- eventKeyVal -- modifiers <- eventModifier @@ -187,7 +157,7 @@ -- return True -- _ -> return False - _ <- after (mWebView gui) keyPressEvent $ do+ _ <- after webView keyPressEvent $ do value <- eventKeyVal modifiers <- eventModifier @@ -196,7 +166,7 @@ case keyString of Just string -> do case Map.lookup (Set.fromList modifiers, string) keyBindings of- Just callback -> liftIO $ callback gui+ Just callback -> liftIO $ callback browser _ -> liftIO $ putStrLn string _ -> return () @@ -221,35 +191,69 @@ -- Connect and show. _ <- onDestroy (mWindow gui) mainQuit widgetShowAll (mWindow gui)- widgetHide (mPromptLabel gui)- widgetHide (mPrompt gui)+ showPrompt False browser mainGUI -- }}} +-- {{{ Util functions+goHome, goBack, goForward, stopLoading :: Browser -> IO ()++-- | Wrapper around webViewGoBack function+goBack browser = webViewGoBack (mWebView $ mGUI browser)+-- | Wrapper around webViewGoForward function+goForward browser = webViewGoForward (mWebView $ mGUI browser)+-- | Wrapper around webViewStopLoading function+stopLoading browser = webViewStopLoading (mWebView $ mGUI browser)+-- | Load homepage (retrieved from commandline options or configuration file)+goHome browser = case (mURI $ mOptions browser) of+ Just uri -> loadURL uri browser+ _ -> loadURL (mHomePage $ mConfiguration browser) browser++-- | Wrapper around webViewReload{BypassCache}+-- If boolean argument is False, it bypasses the cache+reload :: Bool -> Browser -> IO()+reload True browser = webViewReload (mWebView $ mGUI browser)+reload _ browser = webViewReloadBypassCache (mWebView $ mGUI browser)++zoomIn, zoomOut :: Browser -> IO()+-- | Wrapper around webViewZoomIn function+zoomIn browser = webViewZoomIn (mWebView $ mGUI browser)+-- | Wrapper around webViewZoomOut function+zoomOut browser = webViewZoomOut (mWebView $ mGUI browser)++-- | Wrapper around webFramePrint function+printPage :: Browser -> IO()+printPage browser = do+ frame <- webViewGetMainFrame (mWebView $ mGUI browser)+ webFramePrint frame+-- }}}++ -- | Show web inspector for current webpage.-showWebInspector :: GUI -> IO ()-showWebInspector gui = do- inspector <- webViewGetInspector (mWebView gui)+showWebInspector :: Browser -> IO ()+showWebInspector browser = do+ inspector <- webViewGetInspector (mWebView $ mGUI browser) webInspectorInspectCoordinates inspector 0 0 -- | Load given URL in the browser.-loadURL :: String -> GUI -> IO ()-loadURL url gui =+loadURL :: String -> Browser -> IO ()+loadURL url browser = case importURL url of- Just url' -> loadURL' url' gui+ Just url' -> loadURL' url' browser _ -> return ()+-- }}} -- | Backend function for loadURL.-loadURL' :: URL -> GUI -> IO ()-loadURL' url@URL {url_type = Absolute _} gui =- webViewLoadUri (mWebView gui) (exportURL url)-loadURL' url@URL {url_type = HostRelative} gui = - webViewLoadUri (mWebView gui) ("file://" ++ exportURL url) >> putStrLn (show url)-loadURL' url@URL {url_type = _} gui = - webViewLoadUri (mWebView gui) ("http://" ++ exportURL url) >> print url+loadURL' :: URL -> Browser -> IO ()+loadURL' url@URL {url_type = Absolute _} browser =+ webViewLoadUri (mWebView $ mGUI browser) (exportURL url)+loadURL' url@URL {url_type = HostRelative} browser = + webViewLoadUri (mWebView $ mGUI browser) ("file://" ++ exportURL url) >> putStrLn (show url)+loadURL' url@URL {url_type = _} browser = + webViewLoadUri (mWebView $ mGUI browser) ("http://" ++ exportURL url) >> print url -- {{{ Dyre showError :: Configuration -> String -> Configuration
Hbro/Gui.hs view
@@ -2,6 +2,8 @@ module Hbro.Gui where -- {{{ Imports+import Hbro.Types+ import Control.Monad.Trans(liftIO) --import Graphics.UI.Gtk.Abstract.Misc@@ -21,17 +23,7 @@ import System.Glib.Signals -- }}} -data GUI = GUI {- mWindow :: Window, -- ^ Main window- mInspectorWindow :: Window, -- ^ WebInspector window- mScrollWindow :: ScrolledWindow, -- ^ ScrolledWindow containing the webview- mWebView :: WebView, -- ^ Browser's webview- mPromptLabel :: Label, -- ^ Description of current prompt- mPrompt :: Entry, -- ^ Prompt entry- mBuilder :: Builder -- ^ Builder object created from XML file-}---- {{{ Load GUI from XML file+-- | Load GUI from XML file loadGUI :: String -> IO GUI loadGUI xmlPath = do builder <- builderNew@@ -64,69 +56,76 @@ return True return $ GUI window inspectorWindow scrollWindow webView promptLabel promptEntry builder--- }}} -- {{{ Prompt -- | Show or hide the prompt bar (label + entry).-showPrompt :: Bool -> GUI -> IO ()-showPrompt toShow gui = case toShow of- False -> do widgetHide (mPromptLabel gui)- widgetHide (mPrompt gui)- _ -> do widgetShow (mPromptLabel gui)- widgetShow (mPrompt gui)+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) -- | Show the prompt bar label and default text. -- As the user validates its entry, the given callback is executed.-prompt :: String -> String -> Bool -> GUI -> (GUI -> IO ()) -> IO ()-prompt label defaultText incremental gui callback = do- -- Show prompt- showPrompt True gui+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+ -- Show prompt+ showPrompt True browser - -- Fill prompt- labelSetText (mPromptLabel gui) label- entrySetText (mPrompt gui) defaultText+ -- Fill prompt+ labelSetText promptLabel label+ entrySetText promptEntry defaultText - widgetGrabFocus (mPrompt gui)+ widgetGrabFocus promptEntry - -- Register callback- case incremental of- True -> do - id1 <- on (mPrompt gui) editableChanged $ - liftIO $ callback gui- rec id2 <- on (mPrompt gui) keyPressEvent $ do- key <- eventKeyName- - case key of- "Return" -> do- liftIO $ showPrompt False gui- liftIO $ signalDisconnect id1- liftIO $ signalDisconnect id2- liftIO $ widgetGrabFocus (mWebView gui)- "Escape" -> do- liftIO $ showPrompt False gui- liftIO $ signalDisconnect id1- liftIO $ signalDisconnect id2- liftIO $ widgetGrabFocus (mWebView gui)- _ -> return ()- return False- return ()+ -- 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 () - _ -> do- rec id <- on (mPrompt gui) keyPressEvent $ do- key <- eventKeyName+ _ -> do+ rec id <- on promptEntry keyPressEvent $ do+ key <- eventKeyName - case key of- "Return" -> do- liftIO $ showPrompt False gui- liftIO $ callback gui- liftIO $ signalDisconnect id- liftIO $ widgetGrabFocus (mWebView gui)- "Escape" -> do- liftIO $ showPrompt False gui- liftIO $ signalDisconnect id- liftIO $ widgetGrabFocus (mWebView gui)- _ -> return ()- return False+ 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 - return ()+ return () -- }}}++fullscreen, unfullscreen :: Browser -> IO()+fullscreen browser = windowFullscreen (mWindow $ mGUI browser)+unfullscreen browser = windowUnfullscreen (mWindow $ mGUI browser)
Hbro/Socket.hs view
@@ -1,7 +1,7 @@ module Hbro.Socket where -- {{{ Imports-import Hbro.Gui+import Hbro.Types import Control.Monad import Data.ByteString.Char8 (pack, unpack)@@ -10,8 +10,8 @@ import System.ZMQ -- }}} -createReplySocket :: String -> GUI -> IO a-createReplySocket socketName gui = withContext 1 $ \context -> do +createReplySocket :: String -> Browser -> IO a+createReplySocket socketName browser = withContext 1 $ \context -> do withSocket context Rep $ \socket -> do bind socket socketName @@ -26,45 +26,45 @@ case unpack command of -- Get information "getUri" -> do- getUri <- postGUISync $ webViewGetUri (mWebView gui)+ getUri <- postGUISync $ webViewGetUri (mWebView $ mGUI browser) case getUri of Just uri -> send socket (pack uri) [] _ -> send socket (pack "ERROR No URL opened") [] "getTitle" -> do- getTitle <- postGUISync $ webViewGetTitle (mWebView gui)+ getTitle <- postGUISync $ webViewGetTitle (mWebView $ mGUI browser) case getTitle of Just title -> send socket (pack title) [] _ -> send socket (pack "ERROR No title") [] "getFaviconUri" -> do- getUri <- postGUISync $ webViewGetIconUri (mWebView gui)+ getUri <- postGUISync $ webViewGetIconUri (mWebView $ mGUI browser) case getUri of Just uri -> send socket (pack uri) [] _ -> send socket (pack "ERROR No favicon uri") [] "getLoadProgress" -> do- progress <- postGUISync $ webViewGetProgress (mWebView gui)+ progress <- postGUISync $ webViewGetProgress (mWebView $ mGUI browser) send socket (pack (show progress)) [] -- Trigger actions ('l':'o':'a':'d':'U':'r':'i':' ':uri) -> do- postGUIAsync $ webViewLoadUri (mWebView gui) uri+ postGUIAsync $ webViewLoadUri (mWebView $ mGUI browser) uri send socket (pack "OK") [] "stopLoading" -> do- postGUIAsync $ webViewStopLoading (mWebView gui) + postGUIAsync $ webViewStopLoading (mWebView $ mGUI browser) send socket (pack "OK") [] "reload" -> do- postGUIAsync $ webViewReload (mWebView gui)+ postGUIAsync $ webViewReload (mWebView $ mGUI browser) send socket (pack "OK") [] "goBack" -> do- postGUIAsync $ webViewGoBack (mWebView gui)+ postGUIAsync $ webViewGoBack (mWebView $ mGUI browser) send socket (pack "OK") [] "goForward" -> do- postGUIAsync $ webViewGoForward (mWebView gui)+ postGUIAsync $ webViewGoForward (mWebView $ mGUI browser) send socket (pack "OK") [] "zoomIn" -> do- postGUIAsync $ webViewZoomIn (mWebView gui)+ postGUIAsync $ webViewZoomIn (mWebView $ mGUI browser) send socket (pack "OK") [] "zoomOut" -> do- postGUIAsync $ webViewZoomOut (mWebView gui)+ postGUIAsync $ webViewZoomOut (mWebView $ mGUI browser) send socket (pack "OK") [] _ -> send socket (pack "ERROR Unknown command") []
+ Hbro/Types.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE DeriveDataTypeable #-} +module Hbro.Types where++-- {{{ Imports+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.Scrolling.ScrolledWindow+import Graphics.UI.Gtk.WebKit.WebSettings+import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.Windows.Window++import Prelude++import System.Console.CmdArgs+-- }}}++data Browser = Browser {+ mOptions :: CliOptions, -- ^ Commandline options+ mConfiguration :: Configuration, -- ^ Custom configuration provided by user+ mGUI :: GUI -- ^ Graphical widgets+}++data CliOptions = CliOptions {+ mURI :: Maybe String -- ^ URI to load at start-up+} deriving (Data, Typeable, Show, Eq)+++data Configuration = Configuration {+ mHomePage :: String, -- ^ Startup page + mSocketDir :: String, -- ^ Path to socket directory ("/tmp" for example)+ mUIFile :: String, -- ^ Path to XML file describing UI (used by GtkBuilder)+ mKeyBindings :: KeyBindingsList, -- ^ List of keybindings+ mWebSettings :: IO WebSettings, -- ^ Web settings+ mAtStartUp :: Browser -> IO (), -- ^ Custom startup instructions+ mError :: Maybe String -- ^ Error+}++data GUI = GUI {+ mWindow :: Window, -- ^ Main window+ 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+ mBuilder :: Builder -- ^ Builder object created from XML file+}++type KeyBindingsList = [(([Modifier], String), (Browser -> IO ()))]
Hbro/Util.hs view
@@ -1,16 +1,19 @@ module Hbro.Util where -import Hbro.Gui (GUI)+-- {{{ Imports+import Hbro.Types -import qualified Data.Set as Set import qualified Data.Map as Map+import qualified Data.Set as Set+ import Graphics.UI.Gtk import System.Process-+-- }}} instance Ord Modifier where m <= m' = fromEnum m <= fromEnum m' +-- {{{ Keybindings functions -- | Converts a keyVal to a String. -- For printable characters, the corresponding String is returned, except for the space character for which "<Space>" is returned. -- For non-printable characters, the corresponding keyName between <> is returned.@@ -36,17 +39,18 @@ -- | Converts key bindings list to a map. -- | Calls importKeyBindings'.-importKeyBindings :: [(([Modifier], String), (GUI -> IO ()))] -> Map.Map (Set.Set Modifier, String) (GUI -> IO ()) +importKeyBindings :: [(([Modifier], String), (Browser -> IO ()))] -> Map.Map (Set.Set Modifier, String) (Browser -> IO ()) importKeyBindings list = Map.fromList $ importKeyBindings' list -- | Converts modifiers list to modifiers sets. -- The order of modifiers in key bindings don't matter. -- Called by importKeyBindings.-importKeyBindings' :: [(([Modifier], String), (GUI -> IO ()))] -> [((Set.Set Modifier, String), (GUI -> IO ()))]+importKeyBindings' :: [(([Modifier], String), (Browser -> IO ()))] -> [((Set.Set Modifier, String), (Browser -> IO ()))] importKeyBindings' (((a, b), c):t) = ((Set.fromList a, b), c):(importKeyBindings' t) importKeyBindings' _ = []-+-- }}} +-- {{{ Run commands -- | Like run `runCommand`, but return IO () runCommand' :: String -> IO () runCommand' command = runCommand command >> return ()@@ -56,3 +60,4 @@ -- `> /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"+-- }}}
examples/Main.hs view
@@ -3,6 +3,7 @@ -- {{{ Imports import Hbro.Core import Hbro.Gui +import Hbro.Types import Hbro.Util import Control.Monad.Trans(liftIO)@@ -19,13 +20,13 @@ import Graphics.UI.Gtk.Scrolling.ScrolledWindow import Graphics.UI.Gtk.WebKit.Download import Graphics.UI.Gtk.WebKit.NetworkRequest-import Graphics.UI.Gtk.WebKit.WebFrame import Graphics.UI.Gtk.WebKit.WebNavigationAction import Graphics.UI.Gtk.WebKit.WebView import Graphics.UI.Gtk.WebKit.WebSettings import Graphics.UI.Gtk.Windows.Window --- import Paths_hbro -- Doesn't work for now+-- Remove this line in your custom hbro.hs+import Paths_hbro import System.Environment import System.Glib.Attributes@@ -36,7 +37,7 @@ main :: IO () main = do- --uiFile <- getDataFileName "examples/ui.xml" -- Doesn't work for now+ uiFile <- getDataFileName "examples/ui.xml" -- Remove this line in your custom hbro.hs configHome <- getEnv "XDG_CONFIG_HOME" hbro Configuration {@@ -47,11 +48,11 @@ mSocketDir = socketDir, -- XML file defining UI (used by GtkBuilder) - --mUIFile = uiFile, -- Doesn't work for now- -- Use this line if you want to use your own UI file in ~/.config/hbro/ui.xml- mUIFile = configHome ++ "/hbro/ui.xml",+ -- In your custom hbro.hs, remove the first line and use instead the second one+ mUIFile = uiFile,+ --mUIFile = configHome ++ "/hbro/ui.xml", - -- URI loaded at startup+ -- URI to load at startup mHomePage = "https://www.google.com", @@ -67,13 +68,14 @@ -- Browse (([], "<"), goBack), (([Shift], ">"), goForward),- (([], "s"), stop),+ (([], "s"), stopLoading), (([], "<F5>"), reload True), (([Shift], "<F5>"), reload False), (([], "^"), horizontalHome), (([], "$"), horizontalEnd), (([], "<Home>"), verticalHome), (([], "<End>"), verticalEnd),+ (([Control], "<Home>"), goHome), -- Display (([Shift], "+"), zoomIn),@@ -159,11 +161,11 @@ -- Custom callbacks- mAtStartUp = \gui -> (let- builder = mBuilder gui- webView = mWebView gui- scrollWindow = mScrollWindow gui- window = mWindow gui+ mAtStartUp = \browser -> (let+ builder = mBuilder (mGUI browser)+ webView = mWebView (mGUI browser)+ scrollWindow = mScrollWindow (mGUI browser)+ window = mWindow (mGUI browser) in do progressLabel <- builderGetObject builder castToLabel "progress" uriLabel <- builderGetObject builder castToLabel "uri"@@ -192,11 +194,12 @@ let keyString = keyToString value case keyString of - Just string -> liftIO $ labelSetMarkup keysLabel $ "<span foreground=\"green\">" ++ show modifiers ++ string ++ "</span>"+ Just string -> liftIO $ labelSetMarkup keysLabel $ "<span foreground=\"green\">" ++ show modifiers ++ escapeMarkup string ++ "</span>" _ -> return () return False + -- Page load _ <- on webView loadStarted $ \_ -> do labelSetMarkup progressLabel "<span foreground=\"red\">0%</span>"@@ -213,12 +216,6 @@ _ <- on webView loadFinished $ \_ -> do labelSetMarkup progressLabel "<span foreground=\"green\">100%</span>" - getUri <- webViewGetUri webView- getTitle <- webViewGetTitle webView- case (getUri, getTitle) of- (Just uri, Just title) -> historyHandler uri title- _ -> return ()- _ <- on webView loadError $ \_ _ _ -> do labelSetMarkup progressLabel "<span foreground=\"red\">ERROR</span>" return False@@ -226,6 +223,7 @@ _ <- on webView titleChanged $ \_ title -> set window [ windowTitle := ("hbro | " ++ title)] + -- Special requests _ <- on webView downloadRequested $ \download -> do getUri <- downloadGetUri download@@ -243,6 +241,16 @@ return False ++ -- History handler+ _ <- on webView loadFinished $ \_ -> do+ getUri <- webViewGetUri webView+ getTitle <- webViewGetTitle webView+ case (getUri, getTitle) of+ (Just uri, Just title) -> historyHandler uri title+ _ -> return ()++ -- On navigating to a new URI -- Return True to forbid navigation, False to allow _ <- on webView navigationPolicyDecisionRequested $ \_ request action policyDecision -> do@@ -291,127 +299,87 @@ -- Definitions where -- Constants- scriptsDir :: String+ scriptsDir, socketDir :: String scriptsDir = "~/.config/hbro/scripts/"-- socketDir :: String- socketDir = "/tmp"-- -- Browse- goBack :: GUI -> IO ()- goBack gui = webViewGoBack (mWebView gui)-- goForward :: GUI -> IO ()- goForward gui = webViewGoForward (mWebView gui)-- stop :: GUI -> IO ()- stop gui = webViewStopLoading (mWebView gui)-- reload :: Bool -> GUI -> IO ()- reload True gui = webViewReload (mWebView gui)- reload _ gui = webViewReloadBypassCache (mWebView gui)-- -- Zoom- zoomIn :: GUI -> IO ()- zoomIn gui = webViewZoomIn (mWebView gui)-- zoomOut :: GUI -> IO ()- zoomOut gui = webViewZoomOut (mWebView gui)+ socketDir = "/tmp" - toggleSourceMode :: GUI -> IO ()- toggleSourceMode gui = do- currentMode <- webViewGetViewSourceMode (mWebView gui)- webViewSetViewSourceMode (mWebView gui) (not currentMode)+ toggleSourceMode :: Browser -> IO()+ toggleSourceMode browser = do+ currentMode <- webViewGetViewSourceMode (mWebView $ mGUI browser)+ webViewSetViewSourceMode (mWebView $ mGUI browser) (not currentMode) -- TODO- toggleStatusBar :: GUI -> IO ()- toggleStatusBar gui = return()+ toggleStatusBar :: Browser -> IO()+ toggleStatusBar browser = return() - promptURL :: Bool -> GUI -> IO () - promptURL False gui = - prompt "Open URL" "" False gui (\g -> do - uri <- entryGetText (mPrompt g)- loadURL uri g)- promptURL _ gui = do- uri <- webViewGetUri (mWebView gui)+ promptURL :: Bool -> Browser -> IO() + promptURL False browser = + prompt "Open URL" "" False browser (\b -> do + uri <- entryGetText (mPromptEntry $ mGUI b)+ loadURL uri b)+ promptURL _ browser = do+ uri <- webViewGetUri (mWebView $ mGUI browser) case uri of- Just url -> prompt "Open URL" url False gui (\g -> do- u <- entryGetText (mPrompt g)- loadURL u g)+ Just url -> prompt "Open URL" url False browser (\b -> do+ u <- entryGetText (mPromptEntry $ mGUI b)+ loadURL u b) _ -> return () - promptFind :: Bool -> Bool -> Bool -> GUI -> IO ()- promptFind caseSensitive forward wrap gui =- prompt "Search" "" True gui (\gui' -> do- keyWord <- entryGetText (mPrompt gui')- found <- webViewSearchText (mWebView gui) keyWord caseSensitive forward wrap+ 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 ()) - findNext :: Bool -> Bool -> Bool -> GUI -> IO()- findNext caseSensitive forward wrap gui = do- keyWord <- entryGetText (mPrompt gui)- found <- webViewSearchText (mWebView gui) keyWord caseSensitive forward wrap + 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 () - printPage :: GUI -> IO ()- printPage gui = do- frame <- webViewGetMainFrame (mWebView gui)- webFramePrint frame-- fullscreen :: GUI -> IO ()- fullscreen gui = windowFullscreen (mWindow gui)-- unfullscreen :: GUI -> IO ()- unfullscreen gui = windowUnfullscreen (mWindow gui)-- -- Copy/paste- copyUri :: GUI -> IO ()- copyUri gui = do- getUri <- webViewGetUri (mWebView gui)+ copyUri, copyTitle, pasteUri :: Browser -> IO()+ copyUri browser = do+ getUri <- webViewGetUri (mWebView $ mGUI browser) case getUri of Just u -> runCommand ("echo -n " ++ u ++ " | xclip") >> return () _ -> return () - copyTitle :: GUI -> IO ()- copyTitle gui = do- getTitle <- webViewGetTitle (mWebView gui)+ copyTitle browser = do+ getTitle <- webViewGetTitle (mWebView $ mGUI browser) case getTitle of Just t -> runCommand ("echo -n " ++ t ++ " | xclip") >> return () _ -> return () - pasteUri :: GUI -> IO ()- pasteUri gui = do+ pasteUri browser = do uri <- readProcess "xclip" ["-o"] []- loadURL uri gui+ loadURL uri browser -- Scrolling- verticalHome :: GUI -> IO ()- verticalHome gui = do- adjustment <- scrolledWindowGetVAdjustment (mScrollWindow gui)+ verticalHome, verticalEnd, horizontalHome, horizontalEnd :: Browser -> IO()+ verticalHome browser = do+ adjustment <- scrolledWindowGetVAdjustment (mScrollWindow $ mGUI browser) lower <- adjustmentGetLower adjustment adjustmentSetValue adjustment lower - verticalEnd :: GUI -> IO ()- verticalEnd gui = do- adjustment <- scrolledWindowGetVAdjustment (mScrollWindow gui)+ verticalEnd browser = do+ adjustment <- scrolledWindowGetVAdjustment (mScrollWindow $ mGUI browser) upper <- adjustmentGetUpper adjustment adjustmentSetValue adjustment upper - horizontalHome :: GUI -> IO ()- horizontalHome gui = do- adjustment <- scrolledWindowGetHAdjustment (mScrollWindow gui)+ horizontalHome browser = do+ adjustment <- scrolledWindowGetHAdjustment (mScrollWindow $ mGUI browser) lower <- adjustmentGetLower adjustment adjustmentSetValue adjustment lower - horizontalEnd :: GUI -> IO ()- horizontalEnd gui = do- adjustment <- scrolledWindowGetHAdjustment (mScrollWindow gui)+ horizontalEnd browser = do+ adjustment <- scrolledWindowGetHAdjustment (mScrollWindow $ mGUI browser) upper <- adjustmentGetUpper adjustment adjustmentSetValue adjustment upper @@ -425,17 +393,16 @@ -- Bookmarks- addToBookmarks :: GUI -> IO ()- addToBookmarks gui = do- getUri <- webViewGetUri (mWebView gui)+ addToBookmarks, loadFromBookmarks :: Browser -> IO()+ addToBookmarks browser = do+ getUri <- webViewGetUri (mWebView $ mGUI browser) case getUri of- Just uri -> prompt "Bookmark with tag:" "" False gui (\g -> do - tags <- entryGetText (mPrompt g)+ Just uri -> prompt "Bookmark with tag:" "" False browser (\b -> do + tags <- entryGetText (mPromptEntry $ mGUI b) runExternalCommand $ scriptsDir ++ "bookmarks.sh add " ++ uri ++ " " ++ tags) _ -> return () - loadFromBookmarks :: GUI -> IO ()- loadFromBookmarks gui = do + loadFromBookmarks browser = do pid <- getProcessID runExternalCommand $ scriptsDir ++ "bookmarks.sh load \"" ++ socketDir ++ "/hbro." ++ show pid ++ "\""
hbro.cabal view
@@ -1,5 +1,5 @@ Name: hbro-Version: 0.5.0+Version: 0.5.1 Synopsis: A suckless minimal KISSy browser -- Description: -- Homepage:@@ -15,6 +15,7 @@ Cabal-version: >=1.8 Build-type: Simple Data-files: examples/ui.xml+Extra-source-files: examples/Main.hs Source-repository head Type: git@@ -38,7 +39,8 @@ Exposed-modules: Hbro.Core, Hbro.Gui,- Hbro.Socket+ Hbro.Socket,+ Hbro.Types, Hbro.Util Ghc-options: -Wall