diff --git a/Hbro/Core.hs b/Hbro/Core.hs --- a/Hbro/Core.hs +++ b/Hbro/Core.hs @@ -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 diff --git a/Hbro/Gui.hs b/Hbro/Gui.hs --- a/Hbro/Gui.hs +++ b/Hbro/Gui.hs @@ -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) diff --git a/Hbro/Socket.hs b/Hbro/Socket.hs --- a/Hbro/Socket.hs +++ b/Hbro/Socket.hs @@ -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") [] diff --git a/Hbro/Types.hs b/Hbro/Types.hs new file mode 100644 --- /dev/null +++ b/Hbro/Types.hs @@ -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 ()))] diff --git a/Hbro/Util.hs b/Hbro/Util.hs --- a/Hbro/Util.hs +++ b/Hbro/Util.hs @@ -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 "" 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" +-- }}} diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -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), (([], ""), reload True), (([Shift], ""), reload False), (([], "^"), horizontalHome), (([], "$"), horizontalEnd), (([], ""), verticalHome), (([], ""), verticalEnd), + (([Control], ""), 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 $ "" ++ show modifiers ++ string ++ "" + Just string -> liftIO $ labelSetMarkup keysLabel $ "" ++ show modifiers ++ escapeMarkup string ++ "" _ -> return () return False + -- Page load _ <- on webView loadStarted $ \_ -> do labelSetMarkup progressLabel "0%" @@ -213,12 +216,6 @@ _ <- on webView loadFinished $ \_ -> do labelSetMarkup progressLabel "100%" - getUri <- webViewGetUri webView - getTitle <- webViewGetTitle webView - case (getUri, getTitle) of - (Just uri, Just title) -> historyHandler uri title - _ -> return () - _ <- on webView loadError $ \_ _ _ -> do labelSetMarkup progressLabel "ERROR" 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 ++ "\"" diff --git a/hbro.cabal b/hbro.cabal --- a/hbro.cabal +++ b/hbro.cabal @@ -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