hbro 0.8.0.0 → 0.9.0.0
raw patch · 13 files changed
+993/−556 lines, 13 filesdep +transformers
Dependencies added: transformers
Files
- Hbro/Config.hs +171/−0
- Hbro/Core.hs +168/−40
- Hbro/Gui.hs +34/−118
- Hbro/Hbro.hs +239/−119
- Hbro/Keys.hs +40/−59
- Hbro/Main.hs +3/−5
- Hbro/Prompt.hs +95/−0
- Hbro/Socket.hs +56/−104
- Hbro/Types.hs +96/−49
- Hbro/Util.hs +60/−32
- README.rst +4/−27
- examples/ui.xml +22/−1
- hbro.cabal +5/−2
+ Hbro/Config.hs view
@@ -0,0 +1,171 @@+module Hbro.Config (+-- * Default configuration+ defaultConfig,+ defaultHooks,+ defaultKeyHandler,+ defaultKeyBindings,+ defaultLinkClickedHook,+ defaultMIMEDisposition,+-- defaultNewWindowHook,+ defaultTitleChangedHook,+ defaultCommandsList+) where++-- {{{ Import+import Hbro.Core+--import Hbro.Keys+import Hbro.Gui+import qualified Hbro.Prompt as Prompt+import Hbro.Types+import Hbro.Util++import Control.Monad.Reader hiding(mapM_)++import Data.Foldable+import Data.Functor+import qualified Data.Map as M++import Graphics.UI.Gtk.Abstract.Widget+import Graphics.UI.Gtk.General.General+import Graphics.UI.Gtk.Entry.Entry+import Graphics.UI.Gtk.WebKit.WebPolicyDecision+import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.Windows.Window++import Prelude hiding(mapM_)++import Network.URI++import System.Console.CmdArgs (whenLoud)+import System.FilePath+import System.Glib.Attributes+-- }}}+++-- | Default configuration.+-- Homepage: DuckDuckGo, socket directory: system's temporary directory,+-- UI file: ~/.config/hbro/, Webkit's default websettings, no key/command binding.+defaultConfig :: Config+defaultConfig = Config {+ mHomePage = "https://duckduckgo.com/",+ mSocketDir = mTemporary,+ mUIFile = (</> "ui.xml") . mConfiguration,+ mWebSettings = [],+ mCommands = defaultCommandsList,+ mHooks = defaultHooks+}++-- | Pack of default hooks+defaultHooks :: Hooks+defaultHooks = Hooks {+ mBackForward = (\_ decision -> io $ webPolicyDecisionUse decision),+ mDownload = defaultDownloadHook,+ mFormResubmitted = (\_ decision -> io $ webPolicyDecisionUse decision),+ mFormSubmitted = (\_ decision -> io $ webPolicyDecisionUse decision),+ mKeyPressed = void . (defaultKeyHandler defaultKeyBindings),+ mLinkClicked = defaultLinkClickedHook,+ mLoadFinished = return (),+ mMIMEDisposition = defaultMIMEDisposition,+ mNewWindow = const $ return (), --defaultNewWindowHook,+ mOtherNavigation = (\_ decision -> io $ webPolicyDecisionUse decision),+ mReload = (\_ decision -> io $ webPolicyDecisionUse decision),+ mStartUp = return (),+ mTitleChanged = defaultTitleChangedHook+}++-- | Warn user about missing download hook.+defaultDownloadHook :: URI -> String -> Int -> K ()+defaultDownloadHook _ _ _ = notify 5000 "No download hook defined."++-- | Look for a callback associated to the given keystrokes and trigger it, if any.+defaultKeyHandler :: KeysList -> String -> K (String, Bool)+defaultKeyHandler keysList keystrokes = do+ io . whenLoud . putStr $ "Key pressed: " ++ keystrokes+ (log', isMapped) <- case M.lookup keystrokes (M.fromList keysList) of+ Just callback -> callback >> return (" (mapped)", True) + _ -> return (" (unmapped)", False)+ io . whenLoud . putStrLn $ log'+ return (keystrokes, isMapped)++-- | Default key bindings.+defaultKeyBindings :: KeysList+defaultKeyBindings = [+-- Browse+ ("M-<Left>", goBack),+ ("M-<Right>", goForward),+ ("C-<Escape>", stopLoading),+ ("<F5>", reload),+ ("C-r", reload),+ ("C-<F5>", reloadBypassCache),+ ("M-r", reloadBypassCache),+ ("C-^", scroll Horizontal (Absolute 0)),+ ("C-$", scroll Horizontal (Absolute 100)),+ ("C-<Home>", scroll Vertical (Absolute 0)),+ ("C-<End>", scroll Vertical (Absolute 100)),+ ("M-<Home>", goHome),+-- Display+ ("C-+", zoomIn),+ ("C--", zoomOut),+ -- ("<F11>", with (mWindow . mGUI) windowFullscreen),+ -- ("<Escape>", with (mWindow . mGUI) windowUnfullscreen),+ ("C-b", with (mStatusBar . mGUI) toggleVisibility),+ ("C-u", toggleSourceMode),+-- Prompt+ ("C-o", Prompt.readURI "Open URI" [] loadURI),+ ("M-o", withURI $ \uri -> Prompt.readURI "Open URI " (show uri) loadURI),+-- Search+ ("/", Prompt.iread "Search " [] $ void . searchText CaseInsensitive Forward Wrap),+ ("C-f", Prompt.iread "Search " [] $ void . searchText CaseInsensitive Forward Wrap),+ ("?", Prompt.iread "Search " [] $ void . searchText CaseInsensitive Backward Wrap),+ ("C-n", withK (mEntry . mPromptBar . mGUI) $ (io . entryGetText) >=> void . searchText CaseInsensitive Forward Wrap),+ ("C-N", withK (mEntry . mPromptBar . mGUI) $ (io . entryGetText) >=> void . searchText CaseInsensitive Backward Wrap),+-- Misc+ ("<Escape>", with (mBox . mPromptBar . mGUI) widgetHide),+ ("C-i", showWebInspector),+ ("C-p", printPage),+ ("C-t", io $ spawn "hbro" []),+ ("C-w", io mainQuit)+ ]++-- | Left click loads the new page in current window, middle click loads the new page in a new window, right click does nothing.+defaultLinkClickedHook :: Button -> URI -> WebPolicyDecision -> K ()+defaultLinkClickedHook ButtonL _uri decision = io $ webPolicyDecisionUse decision+defaultLinkClickedHook ButtonM uri decision = io $ webPolicyDecisionIgnore decision >> spawn "hbro" ["-u", show uri]+defaultLinkClickedHook _ _uri decision = io $ webPolicyDecisionIgnore decision++-- /!\ NetworkRequest's Haskell binding is missing the function "webkit_network_request_get_message", which makes it rather useless...+-- | Display content if webview can show the given MIME type, otherwise download it.+defaultMIMEDisposition :: URI -> String -> WebPolicyDecision -> K ()+defaultMIMEDisposition _uri mimetype decision = with (mWebView . mGUI) $ \view -> do+ canShow <- webViewCanShowMimeType view mimetype++ case canShow of+ True -> webPolicyDecisionUse decision+ _ -> webPolicyDecisionDownload decision++--- | Default behavior when a new window is requested: load URI in current window.+--defaultNewWindowHook :: URI -> K ()+--defaultNewWindowHook uri = loadURI uri++-- | Update the main window's title+defaultTitleChangedHook :: String -> K () +defaultTitleChangedHook title = with (mWindow . mGUI) (`set` [ windowTitle := ("hbro | " ++ title)])++-- | List of default supported requests.+defaultCommandsList :: CommandsList+defaultCommandsList = [+ -- Get information+ ("GET_URI", \_arguments -> (maybe "ERROR" show) <$> mapK postGUISync getURI),+ ("GET_TITLE", \_arguments -> (maybe "ERROR" show) <$> mapK postGUISync getTitle),+ ("GET_FAVICON_URI", \_arguments -> (maybe "ERROR" show) <$> mapK postGUISync getFaviconURI),+ ("GET_LOAD_PROGRESS", \_arguments -> show <$> mapK postGUISync getLoadProgress),+ -- Trigger actions+ ("LOAD_URI", \arguments -> case arguments of + uri:_ -> ((mapK postGUIAsync) . (mapM_ loadURI)) (parseURIReference uri) >> return "OK"+ _ -> return "ERROR Argument needed."),+ ("STOP_LOADING", \_arguments -> mapK postGUIAsync stopLoading >> return "OK"),+ ("RELOAD", \_arguments -> mapK postGUIAsync reload >> return "OK"),+ ("GO_BACK", \_arguments -> mapK postGUIAsync goBack >> return "OK"),+ ("GO_FORWARD", \_arguments -> mapK postGUIAsync goForward >> return "OK"),+ ("ZOOM_IN", \_arguments -> mapK postGUIAsync zoomIn >> return "OK"),+ ("ZOOM_OUT", \_arguments -> mapK postGUIAsync zoomOut >> return "OK")]
Hbro/Core.hs view
@@ -1,14 +1,39 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DoRec #-} module Hbro.Core (--- * Browsing+-- * 'K'-monad+ runK,+ mapK,+ mapK2,+-- * Util+ with,+ withK,+ withTitle, + withURI,+-- * Read state+ getFaviconURI,+ getLoadProgress,+ getTitle,+ getURI,+ getState,+-- * Browse+ goBack,+ goForward, goHome,--- * Scrolling - goTop,- goBottom,- goLeft,- goRight,+ loadURI,+ reload,+ reloadBypassCache,+ stopLoading,+-- * Display+ zoomIn,+ zoomOut,+ Axis(..),+ Position(..),+ scroll, -- * Misc+ notify,+ searchText,+ toggleSourceMode, printPage, executeJSFile ) where@@ -17,64 +42,167 @@ import Hbro.Types import Hbro.Util +import Control.Monad.Reader hiding(forM_, mapM_)++import Data.Dynamic import Data.Foldable+import Data.Functor+import Data.IORef+import qualified Data.Map as M +import Graphics.UI.Gtk.Display.Label+import Graphics.UI.Gtk.General.General import Graphics.UI.Gtk.Misc.Adjustment import Graphics.UI.Gtk.Scrolling.ScrolledWindow import Graphics.UI.Gtk.WebKit.WebDataSource import Graphics.UI.Gtk.WebKit.WebFrame-import Graphics.UI.Gtk.WebKit.WebView hiding(webViewGetUri, webViewLoadUri)+import Graphics.UI.Gtk.WebKit.WebView import Network.URI +import Prelude hiding(mapM_)+ import System.Console.CmdArgs -- }}} --- {{{ Browsing--- | Load homepage (set from configuration file).-goHome :: WebView -> Config -> IO ()-goHome webView config@Config{ mHomePage = homeURI } = forM_ (parseURIReference homeURI) $ webViewLoadUri webView+-- {{{ 'K'-monad+-- | 'runReaderT' for 'K'-monad+runK :: Environment -> KT m a -> m a+runK env (KT function) = runReaderT function env++-- | 'mapReaderT' for 'K'-monad.+mapK :: (m a -> n b) -> KT m a -> KT n b+mapK function (KT env) = KT $ mapReaderT function env++-- | Like 'mapK', but monadic-input of filter can do little reading.+mapK2 :: ((c -> m a) -> n b) -> (c -> KT m a) -> KT n b+mapK2 f g = KT . ReaderT $ \b -> f (runK b . g) -- }}} --- {{{ Scrolling--- | Scroll up to top of web page. Provided for convenience.-goTop :: ScrolledWindow -> IO ()-goTop window = do- adjustment <- scrolledWindowGetVAdjustment window- lower <- adjustmentGetLower adjustment+-- {{{ Util+with :: (Environment -> a) -> (a -> IO b) -> K b+with selector callback = withK selector $ io . callback - adjustmentSetValue adjustment lower+withK :: (Environment -> a) -> (a -> K b) -> K b+withK selector callback = callback =<< asks selector --- | Scroll down to bottom of web page. Provided for convenience.-goBottom :: ScrolledWindow -> IO ()-goBottom window = do- adjustment <- scrolledWindowGetVAdjustment window- upper <- adjustmentGetUpper adjustment+withTitle :: (String -> K ()) -> K ()+withTitle callback = (mapM_ callback) =<< getTitle - adjustmentSetValue adjustment upper+withURI :: (URI -> K ()) -> K ()+withURI callback = (mapM_ callback) =<< getURI --- | Scroll to the left edge of web page. Provided for convenience.-goLeft :: ScrolledWindow -> IO ()-goLeft window = do- adjustment <- scrolledWindowGetHAdjustment window- lower <- adjustmentGetLower adjustment+getFaviconURI :: K (Maybe URI)+getFaviconURI = with (mWebView . mGUI) $ (return . (parseURI =<<)) <=< webViewGetIconUri - adjustmentSetValue adjustment lower+getLoadProgress :: K Double+getLoadProgress = with (mWebView . mGUI) webViewGetProgress --- | Scroll to the right edge of web page. Provided for convenience.-goRight :: ScrolledWindow -> IO ()-goRight window = do- adjustment <- scrolledWindowGetHAdjustment window- upper <- adjustmentGetUpper adjustment+getURI :: K (Maybe URI)+getURI = with (mWebView . mGUI) $ (return . (parseURI =<<)) <=< webViewGetUri - adjustmentSetValue adjustment upper +getTitle :: K (Maybe String)+getTitle = with (mWebView . mGUI) webViewGetTitle++getState :: Typeable a => String -> a -> K (IORef a) +getState key defaultValue = with mState $ \state -> do+ result <- (fromDynamic <=< M.lookup key) <$> readIORef state + case result of+ Just value -> return value+ _ -> do+ value <- newIORef defaultValue+ modifyIORef state . M.insert key . toDyn $ value + return value -- }}}- ++-- {{{ Browsing+goBack, goForward, goHome :: K ()+goBack = withK (mWebView . mGUI) $ \view -> do+ canGoBack <- io . webViewCanGoBack $ view+ unless canGoBack $ notify 5000 "Cannot go back anymore"+ io . webViewGoBack $ view+goForward = withK (mWebView . mGUI) $ \view -> do+ canGoForward <- io . webViewCanGoForward $ view+ unless canGoForward $ notify 5000 "Cannot go forward anymore"+ io . webViewGoForward $ view++goHome = withK (mHomePage . mConfig) $ mapM_ loadURI . parseURIReference++loadURI :: URI -> K ()+loadURI uri = do+ io . whenLoud . putStrLn . ("Loading URI: " ++) . show $ uri'+ with (mWebView . mGUI) (`webViewLoadUri` uri')+ where+ uri' = case uriScheme uri of+ [] -> "http://" ++ show uri+ _ -> show uri++reload, reloadBypassCache, stopLoading :: K ()+reload = with (mWebView . mGUI) webViewReload+reloadBypassCache = with (mWebView . mGUI) webViewReloadBypassCache+stopLoading = do+ with (mWebView . mGUI) webViewStopLoading+ notify 5000 "Stopped loading"+-- }}}++-- {{{ Display+zoomIn, zoomOut :: K ()+zoomIn = with (mWebView . mGUI) webViewZoomIn+zoomOut = with (mWebView . mGUI) webViewZoomOut++data Axis = Horizontal | Vertical+data Position = Absolute Double | Relative Double++getAdjustment :: Axis -> (ScrolledWindow -> IO Adjustment)+getAdjustment Horizontal = scrolledWindowGetHAdjustment+getAdjustment Vertical = scrolledWindowGetVAdjustment++-- | General scrolling command. +scroll :: Axis -> Position -> K ()+scroll axis percentage = with (mScrollWindow . mGUI) $ \window -> do+ adj <- getAdjustment axis window+ page <- adjustmentGetPageSize adj+ current <- adjustmentGetValue adj+ lower <- adjustmentGetLower adj+ upper <- adjustmentGetUpper adj+ + let shift (Absolute x) = lower + x/100 * (upper - page - lower)+ shift (Relative x) = current + x/100 * page+ limit x = (x `max` lower) `min` (upper - page)+ + adjustmentSetValue adj $ limit (shift percentage) +-- }}}+ -- {{{ Misc--- | Wrapper around webFramePrint function, provided for convenience.-printPage :: WebView -> IO ()-printPage webView = webViewGetMainFrame webView >>= webFramePrint+notify :: Int -> String -> K ()+notify duration text = with (mNotificationBar . mGUI) $ \notificationBar -> do+-- Set new content+ let label = mLabel notificationBar+ labelSetMarkup label text+-- Remove old timer, if any+ let timer = mTimer notificationBar+ oldID <- readIORef timer+ forM_ oldID timeoutRemove+-- Add new timer+ newID <- timeoutAdd (labelSetMarkup label "" >> return False) duration+ modifyIORef timer $ const . Just $ newID +-- | Wrapper around webViewSearchText, provided for convenience+searchText :: CaseSensitivity -> Direction -> Wrap -> String -> K Bool+searchText s d w text = with (mWebView . mGUI) $ \view -> + webViewSearchText view text (isCaseSensitive s) (isForward d) (isWrapped w)++-- | Toggle source display.+-- Current implementation forces a refresh of current web page, which may be undesired.+toggleSourceMode :: K ()+toggleSourceMode = do+ with (mWebView . mGUI) $ \view -> + webViewSetViewSourceMode view =<< (not <$> webViewGetViewSourceMode view)+ reload++-- | Wrapper around webFramePrint function, provided for convenience.+printPage :: K ()+printPage = with (mWebView . mGUI) $ webViewGetMainFrame >=> webFramePrint -- | Execute a javascript file on current webpage. executeJSFile :: FilePath -> WebView -> IO ()
Hbro/Gui.hs view
@@ -1,20 +1,21 @@ {-# LANGUAGE DoRec #-} module Hbro.Gui (+ getObject, initGUI, showWebInspector,- prompt,- promptIncremental, toggleVisibility ) where -- {{{ Imports+import Hbro.Core import Hbro.Util+import qualified Hbro.Prompt as Prompt import Hbro.Types import Control.Monad hiding(forM_, mapM_)-import Control.Monad.Trans -import Data.Foldable+--import Data.Foldable+import Data.IORef import Graphics.Rendering.Pango.Enums import Graphics.UI.Gtk.Abstract.Container@@ -22,10 +23,7 @@ import Graphics.UI.Gtk.Abstract.Widget import Graphics.UI.Gtk.Builder import Graphics.UI.Gtk.Display.Label-import Graphics.UI.Gtk.Entry.Editable-import Graphics.UI.Gtk.Entry.Entry import qualified Graphics.UI.Gtk.General.General as GTK-import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.Layout.HBox import Graphics.UI.Gtk.Layout.VBox import Graphics.UI.Gtk.Scrolling.ScrolledWindow@@ -36,27 +34,32 @@ import Prelude hiding(mapM_) -import System.Console.CmdArgs (whenNormal, whenLoud)+import System.Console.CmdArgs (whenNormal) import System.Glib.Attributes import System.Glib.Signals+import System.Glib.Types -- }}} -initGUI :: FilePath -> [AttrOp WebSettings] -> IO GUI+-- Util+-- | Return the casted GObject corresponding to the given name (set in the builder's XML file)+getObject :: GObjectClass a => (GObject -> a) -> String -> K a +getObject cast name = with (mBuilder . mGUI) $ \builder -> builderGetObject builder cast name++initGUI :: (RefDirs -> FilePath) -> [AttrOp WebSettings] -> IO GUI initGUI xmlPath settings = do- whenNormal $ putStr ("Loading GUI from " ++ xmlPath ++ "... ") void GTK.initGUI- -- Load XML+ xmlPath' <- resolve xmlPath+ whenNormal . putStr . ("Loading GUI from " ++) . (++ "... ") $ xmlPath' builder <- builderNew- builderAddFromFile builder xmlPath- + builderAddFromFile builder xmlPath' -- Initialize components- (webView, sWindow) <- initWebView builder settings- (window, wBox) <- initWindow builder webView- promptBar <- initPromptBar builder- statusBar <- initStatusBar builder- inspectorWindow <- initWebInspector webView wBox- + (webView, sWindow) <- initWebView builder settings+ (window, wBox) <- initWindow builder webView+ promptBar <- Prompt.init builder+ statusBar <- initStatusBar builder+ notificationBar <- initNotificationBar builder+ inspectorWindow <- initWebInspector webView wBox -- Show window widgetShowAll window widgetHide (mBox promptBar)@@ -69,6 +72,7 @@ mWebView = webView, mPromptBar = promptBar, mStatusBar = statusBar, + mNotificationBar = notificationBar, mBuilder = builder } @@ -77,27 +81,17 @@ -- Initialize ScrolledWindows window <- builderGetObject builder castToScrolledWindow "webViewParent" scrolledWindowSetPolicy window PolicyNever PolicyNever- -- Initialize WebSettings webSettings <- webSettingsNew set webSettings settings- -- Initialize WebView webView <- webViewNew set webView [ widgetCanDefault := True ] webViewSetWebSettings webView webSettings- containerAdd window webView- + containerAdd window webView -- _ <- on webView closeWebView $ GTK.mainQuit >> return False --- On new window request- _ <- on webView createWebView $ \frame -> do- webFrameGetUri frame >>= (mapM_ (\uri -> do- whenLoud $ putStrLn ("Requesting new window: " ++ show uri ++ "...")- webViewLoadUri webView uri))- return webView- return (webView, window) initWindow :: Builder -> WebView -> IO (Window, VBox)@@ -111,24 +105,16 @@ box <- builderGetObject builder castToVBox "windowBox" return (window, box)--initPromptBar :: Builder -> IO PromptBar-initPromptBar builder = do- label <- builderGetObject builder castToLabel "promptDescription"- labelSetAttributes label [- AttrStyle {paStart = 0, paEnd = -1, paStyle = StyleItalic},- AttrWeight {paStart = 0, paEnd = -1, paWeight = WeightBold}- ] - entry <- builderGetObject builder castToEntry "promptEntry"- box <- builderGetObject builder castToHBox "promptBox"- - return $ PromptBar box label entry- initStatusBar :: Builder -> IO HBox initStatusBar builder = builderGetObject builder castToHBox "statusBox"- +initNotificationBar :: Builder -> IO NotificationBar+initNotificationBar builder = do+ label <- builderGetObject builder castToLabel "notificationLabel"+ timer <- newIORef Nothing+ return $ NotificationBar label timer+ -- {{{ Web inspector initWebInspector :: WebView -> VBox -> IO (Window) initWebInspector webView windowBox = do @@ -177,81 +163,11 @@ return inspectorWindow - -- | Show web inspector for current webpage.-showWebInspector :: WebView -> IO ()-showWebInspector webView = do- inspector <- webViewGetInspector webView- webInspectorInspectCoordinates inspector 0 0--- }}}----- {{{ Prompt-openPrompt :: PromptBar -> String -> String -> IO ()-openPrompt _promptBar@PromptBar {mBox = promptBox, mDescription = description, mEntry = entry} newDescription defaultText = do- labelSetText description newDescription- entrySetText entry defaultText- - widgetShow promptBox- widgetGrabFocus entry- editableSetPosition entry (-1)- --- | Open prompt bar with given description and default value,--- and register a callback to trigger at validation.-prompt :: String -> String -> (String -> IO ()) -> GUI -> IO ()-prompt l d = prompt' l d False---- | Same as 'prompt', but callback is triggered for each change in prompt's entry.-promptIncremental :: String -> String -> (String -> IO ()) -> GUI -> IO ()-promptIncremental l d = prompt' l d True--prompt' :: String -> String -> Bool -> (String -> IO ()) -> GUI -> IO ()-prompt' description defaultText incremental callback _gui@GUI {mPromptBar = promptBar, mWebView = webView} = do- openPrompt promptBar description defaultText---- Register callback- case incremental of- True -> do - id1 <- on entry editableChanged $ entryGetText entry >>= callback- rec id2 <- on entry keyPressEvent $ do- key <- eventKeyName- - case key of- "Return" -> liftIO $ do- widgetHide promptBox- signalDisconnect id1- signalDisconnect id2- widgetGrabFocus webView- "Escape" -> liftIO $ do- widgetHide promptBox- signalDisconnect id1- signalDisconnect id2- widgetGrabFocus webView- _ -> return ()- return False- return ()-- _ -> do- rec id <- on entry keyPressEvent $ do- key <- eventKeyName-- case key of- "Return" -> liftIO $ do- widgetHide promptBox- entryGetText entry >>= callback- signalDisconnect id- widgetGrabFocus webView- "Escape" -> liftIO $ do- widgetHide promptBox- signalDisconnect id- widgetGrabFocus webView- _ -> return ()- return False-- return ()- where- promptBox = mBox promptBar- entry = mEntry promptBar+showWebInspector :: K ()+showWebInspector = do+ inspector <- with (mWebView . mGUI) webViewGetInspector+ io $ webInspectorInspectCoordinates inspector 0 0 -- }}}
Hbro/Hbro.hs view
@@ -2,40 +2,54 @@ {-# LANGUAGE DoRec #-} module Hbro.Hbro ( -- * Main- defaultConfig, launchHbro ) where -- {{{ Imports+--import Hbro.Config import Hbro.Core import Hbro.Gui import Hbro.Keys-import Hbro.Socket+import qualified Hbro.Prompt as Prompt+import qualified Hbro.Socket as Socket import Hbro.Types import Hbro.Util import qualified Config.Dyre as D+import Config.Dyre.Compile import Config.Dyre.Paths -import Control.Concurrent-import Control.Monad.Reader+--import Control.Concurrent+import Control.Monad.Reader hiding(forM_, mapM_) +import Data.Dynamic+import Data.Foldable+import Data.IORef import qualified Data.Map as M import Graphics.UI.Gtk.Abstract.Widget+import Graphics.UI.Gtk.Entry.Editable+import Graphics.UI.Gtk.Entry.Entry import Graphics.UI.Gtk.General.General hiding(initGUI)-import Graphics.UI.Gtk.WebKit.WebView hiding(webViewGetUri, webViewLoadUri)+import Graphics.UI.Gtk.Gdk.EventM 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.WebPolicyDecision+import Graphics.UI.Gtk.WebKit.WebView import Network.URI +import Prelude hiding(concat, mapM_)+ import System.Console.CmdArgs import System.Directory-import System.Environment.XDG.BaseDir+import System.Exit import System.FilePath import System.Glib.Signals import System.IO-import System.Posix.Process+--import System.Posix.Process import System.Posix.Signals import qualified System.ZMQ as ZMQ -- }}}@@ -43,25 +57,45 @@ -- {{{ Commandline options cliOptions :: CliOptions cliOptions = CliOptions {- mURI = def &= help "URI to open at start-up" &= explicit &= name "u" &= name "uri" &= typ "URI",- mVanilla = def &= help "Do not read custom configuration file." &= explicit &= name "1" &= name "vanilla",- mDenyReconf = def &= help "Deny recompilation even if the configuration file has changed." &= explicit &= name "deny-reconf",- mForceReconf = def &= help "Force recompilation even if the configuration file hasn't changed." &= explicit &= name "force-reconf",- mDyreDebug = def &= help "Force the application to use './cache/' as the cache directory, and ./ as the configuration directory. Useful to debug the program without installation." &= explicit &= name "dyre-debug",- mMasterBinary = def &= explicit &= name "dyre-master-binary"+ mURI = def &= help "URI to open at start-up" &= explicit &= name "u" &= name "uri" &= typ "URI",+ mVanilla = def &= help "Do not read custom configuration file." &= explicit &= name "1" &= name "vanilla",+ mRecompile = def &= help "Force recompilation and do not launch browser." &= explicit &= name "r" &= name "recompile",+ mDenyReconf = def &= help "Deny recompilation even if the configuration file has changed." &= explicit &= name "deny-reconf",+ mForceReconf = def &= help "Force recompilation even if the configuration file hasn't changed." &= explicit &= name "force-reconf",+ mDyreDebug = def &= help "Force the application to use './cache/' as the cache directory, and ./ as the configuration directory. Useful to debug the program without installation." &= explicit &= name "dyre-debug",+ mMasterBinary = def &= explicit &= name "dyre-master-binary" } getOptions :: IO CliOptions getOptions = cmdArgs $ cliOptions- &= verbosityArgs [explicit, name "verbose", name "v"] []- &= versionArg [ignore]- &= help "A minimal KISS-compliant browser."- &= helpArg [explicit, name "help", name "h"]- &= program "hbro"+ &= verbosityArgs [explicit, name "verbose", name "v"] []+ &= versionArg [ignore]+ &= help "A minimal KISS-compliant browser."+ &= helpArg [explicit, name "help", name "h"]+ &= program "hbro" -- }}} --- {{{ Configuration (Dyre)-dyreParameters :: D.Params (Config, CliOptions)+-- {{{ Util+printDyrePaths :: IO ()+printDyrePaths = getPaths dyreParameters >>= \(a,b,c,d,e) -> (putStrLn . unlines) [+ "Current binary: " ++ a,+ "Custom binary: " ++ b,+ "Config file: " ++ c,+ "Cache directory: " ++ d,+ "Lib directory: " ++ e, []]++-- | Launch a recompilation of the configuration file+recompile :: IO (Maybe String)+recompile = do+ customCompile dyreParameters + getErrorString dyreParameters ++showError :: (Config', a) -> String -> (Config', a)+showError (_, x) message = (Left message, x)+-- }}}++-- {{{ Entry point +dyreParameters :: D.Params (Config', CliOptions) dyreParameters = D.defaultParams { D.projectName = "hbro", D.showError = showError,@@ -70,122 +104,208 @@ D.statusOut = hPutStrLn stderr } -showError :: (Config, a) -> String -> (Config, a)-showError (config, x) message = (config { mError = Just message }, x)---- | Default configuration.--- Homepage: Google, socket directory: /tmp,--- UI file: ~/.config/hbro/, no key/command binding.-defaultConfig :: CommonDirectories -> Config-defaultConfig directories = Config {- mCommonDirectories = directories,- mHomePage = "https://encrypted.google.com/",- mSocketDir = mTemporary directories,- mUIFile = (mConfiguration directories) </> "ui.xml",- mKeyEventHandler = simpleKeyEventHandler,- mKeyEventCallback = \_ -> simpleKeyEventCallback (keysListToMap []),- mWebSettings = [],- mSetup = const (return () :: IO ()),- mCommands = [],- mDownloadHook = \_ _ _ _ -> return (),- mError = Nothing-}--- }}}---- {{{ Entry point -- | Browser's main function. -- To be called in main function with a proper configuration. -- See Hbro.Main for an example.-launchHbro :: (CommonDirectories -> Config) -> IO ()-launchHbro configGenerator = do- homeDir <- getHomeDirectory- tmpDir <- getTemporaryDirectory- configDir <- getUserConfigDir "hbro"- dataDir <- getUserDataDir "hbro"- - let config = configGenerator (CommonDirectories homeDir tmpDir configDir dataDir)-+launchHbro :: Config -> IO ()+launchHbro config = do options <- getOptions+-- Handle recompilation+ when (mRecompile options) $+ recompile+ >>= maybe exitSuccess (\e -> putStrLn e >> exitFailure)+-- Handle vanilla mode case mVanilla options of- True -> D.wrapMain dyreParameters{ D.configCheck = False } (config, options)- _ -> D.wrapMain dyreParameters (config, options)--realMain :: (Config, CliOptions) -> IO ()-realMain (config, options) = do--- Print configuration error, if any- maybe (return ()) putStrLn $ mError config---- Print in-use paths- whenLoud $ getPaths dyreParameters >>= \(a,b,c,d,e) -> (putStrLn . unlines) [- "Current binary: " ++ a,- "Custom binary: " ++ b,- "Config file: " ++ c,- "Cache directory: " ++ d,- "Lib directory: " ++ e,- []]- --- Initialize GUI- gui <- initGUI (mUIFile config) (mWebSettings config)+ True -> D.wrapMain dyreParameters{ D.configCheck = False } (Right config, options)+ _ -> D.wrapMain dyreParameters (Right config, options) --- Initialize IPC socket- ZMQ.withContext 1 $ realMain' config options gui+-- At this point, the reconfiguration process is done+realMain :: (Config', CliOptions) -> IO ()+realMain (Left e, _) = putStrLn e+realMain (Right config, options) = do+-- Handle SIGINT+ void $ installHandler sigINT (Catch interruptHandler) Nothing+-- Print configuration state+ whenLoud printDyrePaths+-- Initialize GUI, state and IPC socket+ gui <- initGUI (mUIFile config) (mWebSettings config)+ state <- newIORef (M.empty :: M.Map String Dynamic)+ + ZMQ.withContext 1 $ \context -> realMain' (Environment state options config gui context)+ whenNormal . putStrLn $ "Exiting..." -realMain' :: Config -> CliOptions -> GUI -> ZMQ.Context -> IO ()-realMain' config options gui@GUI {mWebView = webView, mWindow = window} context = let- environment = Environment options config gui context- setup = mSetup config- socketDir = mSocketDir config - commands = mCommands config- keyEventHandler = mKeyEventHandler config- keyEventCallback = (mKeyEventCallback config) environment- in do--- Apply custom setup- setup environment+realMain' :: Environment -> IO ()+realMain' environment@Environment{ mOptions = options, mConfig = config, mGUI = gui} = let+ entry = (mEntry . mPromptBar) gui+ webView = mWebView gui+ hooks = mHooks config+ in do +-- Bind hooks+ void $ on webView titleChanged (onTitleChanged environment)+ void $ on webView loadFinished (\_frame -> runK environment $ mLoadFinished hooks)+ void $ on webView navigationPolicyDecisionRequested (onNavigationRequest environment)+ void $ on webView newWindowPolicyDecisionRequested (onNewWindow environment)+ void $ on webView createWebView (onNewWebView environment)+ void $ on webView downloadRequested (onDownload environment)+ void $ on webView mimeTypePolicyDecisionRequested (onMIMEDisposition environment) --- Bind download hook- void $ on webView downloadRequested $ \download -> do- uri <- (>>= parseURI) `fmap` downloadGetUri download- filename <- downloadGetSuggestedFilename download- size <- downloadGetTotalSize download- - case (uri, filename) of- (Just uri', Just filename') -> do- whenNormal $ putStrLn ("Requested download: " ++ show uri')- (mDownloadHook config) environment uri' filename' size- _ -> return ()- return False- --- Setup key handler- rec i <- after webView keyPressEvent $ keyEventHandler keyEventCallback i webView+ void $ after webView keyPressEvent (onKeyPressed environment)+ void $ on entry keyPressEvent (onPromptKeyPress environment)+ void $ on entry editableChanged (onPromptChanged environment) --- Load homepage+-- Set start-up page startURI <- case (mURI options) of Just uri -> do fileURI <- doesFileExist uri case fileURI of- True -> getCurrentDirectory >>= \dir -> return $ Just ("file://" ++ dir </> uri)- _ -> return $ Just uri+ True -> getCurrentDirectory >>= \dir -> return $ parseURIReference ("file://" ++ dir </> uri)+ _ -> return $ parseURIReference uri _ -> return Nothing - maybe (goHome webView config) (webViewLoadUri webView) (startURI >>= parseURIReference)---- Open socket- pid <- getProcessID- let commandsList = M.fromList $ defaultCommandsList ++ commands- let socketURI = "ipc://" ++ socketDir ++ pathSeparator:"hbro." ++ show pid- void $ forkIO (openRepSocket context socketURI (listenToCommands environment commandsList))- --- Manage POSIX signals- void $ installHandler sigINT (Catch interruptHandler) Nothing-- --timeoutAdd (putStrLn "OK" >> return True) 2000- mainGUI -- Main loop+ runK environment $ do+ Socket.open --- Make sure response socket is closed at exit- whenLoud $ putStrLn "Closing socket..."- closeSocket context socketURI- whenNormal $ putStrLn "Exiting..."+ -- Custom start-up+ mStartUp . mHooks $ config+ -- Load home page + maybe goHome loadURI startURI+ -- Main loop+ io mainGUI+ + Socket.close interruptHandler :: IO () interruptHandler = whenLoud (putStrLn "Received SIGINT.") >> mainQuit -- }}}++-- {{{ Hooks+onDownload :: Environment -> Download -> IO Bool+onDownload environment download = do+ uri <- (>>= parseURI) `fmap` downloadGetUri download+ filename <- downloadGetSuggestedFilename download+ size <- downloadGetTotalSize download+ + case (uri, filename) of+ (Just uri', Just filename') -> do+ whenLoud . putStrLn . ("Requested download: " ++) . show $ uri'+ runK environment $ do+ notify 5000 $ "Requested download: " ++ filename' ++ " (" ++ show size ++ ")"+ callback uri' filename' size+ _ -> return ()+ return False+ where + callback = mDownload . mHooks . mConfig $ environment++onKeyPressed :: Environment -> EventM EKey Bool+onKeyPressed env = do+ modifiers <- eventModifier+ key' <- keyToString `fmap` eventKeyVal++ io . forM_ key' $ \key -> do + let keystrokes = (++ key) . concat . map stringify $ modifiers+ runK env $ (mKeyPressed hooks) keystrokes+ return False+ where+ hooks = mHooks . mConfig $ env++onMIMEDisposition :: Environment -> WebFrame -> NetworkRequest -> String -> WebPolicyDecision -> IO Bool+onMIMEDisposition env _frame request mimetype decision = do+ uri <- (>>= parseURIReference) `fmap` networkRequestGetUri request+ forM_ uri (\u -> runK env $ hook u mimetype decision)+ return True+ where+ hook = mMIMEDisposition . mHooks . mConfig $ env++onNavigationRequest :: Environment -> WebFrame -> NetworkRequest -> WebNavigationAction -> WebPolicyDecision -> IO Bool+onNavigationRequest environment _frame request action decision = do+ uri <- (>>= parseURIReference) `fmap` networkRequestGetUri request+ reason <- webNavigationActionGetReason action+ button <- webNavigationActionGetButton action++ let behavior = case (reason, button, uri) of+ (WebNavigationReasonLinkClicked, 1, Just u) -> (mLinkClicked hooks) ButtonL u decision+ (WebNavigationReasonLinkClicked, 2, Just u) -> (mLinkClicked hooks) ButtonM u decision+ (WebNavigationReasonLinkClicked, 3, Just u) -> (mLinkClicked hooks) ButtonR u decision+ (WebNavigationReasonFormSubmitted, _, Just u) -> (mFormSubmitted hooks) u decision+ (WebNavigationReasonBackForward, _, Just u) -> (mBackForward hooks) u decision+ (WebNavigationReasonReload, _, Just u) -> (mReload hooks) u decision+ (WebNavigationReasonFormResubmitted, _, Just u) -> (mFormResubmitted hooks) u decision+ (WebNavigationReasonOther, _, Just u) -> (mOtherNavigation hooks) u decision+ + (WebNavigationReasonLinkClicked, x, Just _) -> io . whenNormal . putStrLn . ("WARNING: link clicked with invalid button: " ++) . show $ x+ _ -> io . whenNormal . putStrLn $ "WARNING: invalid link clicked."+ + runK environment behavior+ return True+ where+ hooks = (mHooks . mConfig) environment++onNewWindow :: Environment -> WebFrame -> NetworkRequest -> WebNavigationAction -> WebPolicyDecision -> IO Bool+onNewWindow _env _frame request _action decision = do + uri <- networkRequestGetUri request+ --reason <- webNavigationActionGetReason action+ --button <- webNavigationActionGetButton action + + case uri of+ Just u -> (putStrLn . ("New window request: " ++) $ u) >> spawn "hbro" ["-u", u]+ _ -> putStrLn "WARNING: wrong URI given, unable to open new window."++ webPolicyDecisionIgnore decision+ + return True+ + ++-- Triggered in 2 cases:+-- 1/ Javascript window.open()+-- 2/ Context menu "Open in new window"+onNewWebView :: Environment -> WebFrame -> IO WebView+onNewWebView _env _frame = do+ --forM_ uri $ (runK env) . callback+ + webView <- webViewNew+ + void . on webView webViewReady $ return True + void . on webView navigationPolicyDecisionRequested $ \_ request _ decision -> do+ networkRequestGetUri request >>= mapM_ (\u -> spawn "hbro" ["-u", u])+ webPolicyDecisionIgnore decision+ return True+ + return webView+ --where+ --callback = mNewWindow . mHooks . mConfig $ environment+ +-- Validate/cancel prompt+onPromptKeyPress :: Environment -> EventM EKey Bool+onPromptKeyPress env = do+ key <- eventKeyName+ io $ do + callback <- readIORef callbackRef++ when (key == "Return") . runK env $ io (entryGetText entry) >>= callback+ when (key == "Return" || key == "Escape") $ do + runK env Prompt.clean+ widgetGrabFocus webView+ return False+ where+ callbackRef = mCallbackRef . mPromptBar . mGUI $ env+ entry = mEntry . mPromptBar . mGUI $ env+ webView = mWebView . mGUI $ env+ +-- Incremental behavior+onPromptChanged :: Environment -> IO ()+onPromptChanged env = do+ callback <- readIORef incrementalCallbackRef+ runK env $ io (entryGetText entry) >>= callback+ where+ incrementalCallbackRef = mIncrementalCallbackRef . mPromptBar . mGUI $ env + entry = mEntry . mPromptBar . mGUI $ env++-- +onTitleChanged :: Environment -> WebFrame -> String -> IO ()+onTitleChanged env _frame title = do+ whenLoud . putStrLn . ("Title changed: " ++) $ title+ runK env $ hook title+ where+ hook = mTitleChanged . mHooks . mConfig $ env+-- }}}
Hbro/Keys.hs view
@@ -1,80 +1,54 @@ {-# LANGUAGE DoRec #-} module Hbro.Keys (--- * Key event callbacks - withKeys,- simpleKeyEventCallback,--- * Key event handlers - simpleKeyEventHandler,- advancedKeyEventHandler,+-- * Other -- * Util+ stringify, keyToString,- keysListToMap + manageSequentialKeys ) where -- {{{ Imports+import Hbro.Core import Hbro.Types+import Hbro.Util ---import Control.Monad-import Control.Monad.Trans+import Control.Monad hiding(forM_)+--import Control.Monad.Trans -import qualified Data.Map as M-import qualified Data.Set as S+--import Data.Foldable+import Data.IORef+--import qualified Data.Map as M+--import qualified Data.Set as S import Graphics.UI.Gtk.Abstract.Widget import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.Gdk.Keys-import Graphics.UI.Gtk.WebKit.WebView -import System.Console.CmdArgs (whenLoud, whenNormal)-import System.Glib.Signals+import Prelude hiding(mapM_)++--import System.Console.CmdArgs (whenLoud)+--import System.Glib.Signals -- }}} -instance Ord Modifier where- m <= m' = fromEnum m <= fromEnum m' --- | Retrieve modifiers and pressed keys, and forward them to a handler.-withKeys :: ([Modifier] -> String -> IO ()) -> EventM EKey Bool-withKeys handler = do- value <- eventKeyVal- modifiers <- eventModifier-- liftIO $ maybe (return ()) (\string -> handler modifiers string) (keyToString value)-- return False---- | Look for a callback associated to the given modifiers and pressed keys and trigger it, if any.-simpleKeyEventCallback :: KeysMap -> KeyEventCallback-simpleKeyEventCallback keysMap modifiers keys = do- whenLoud $ putStr ("Key pressed: " ++ show modifiers ++ keys ++ " ")- - case M.lookup (S.fromList modifiers, keys) keysMap of- Just callback -> callback >> (whenLoud $ putStrLn "(mapped)") >> return True- _ -> (whenLoud $ putStrLn "(unmapped)") >> return False---- | Basic key handler which doesn't support sequential keystrokes.-simpleKeyEventHandler :: KeyEventCallback -> ConnectId WebView -> WebView -> EventM EKey Bool-simpleKeyEventHandler callback _ _ = withKeys (\x y -> callback x y >> return ())---- | Key handler with sequential keystrokes support.-advancedKeyEventHandler :: KeyEventCallback -> ConnectId WebView -> WebView -> EventM EKey Bool-advancedKeyEventHandler = advancedKeyEventHandler' []- -advancedKeyEventHandler' :: String -> KeyEventCallback -> ConnectId WebView -> WebView -> EventM EKey Bool-advancedKeyEventHandler' previousKeys callback oldID webView = withKeys $ \modifiers newKey -> do- let keys = previousKeys ++ newKey- let newHandler = \x -> do- rec newID <- after webView keyPressEvent $ advancedKeyEventHandler' x callback newID webView- return ()- - signalDisconnect oldID- result <- callback modifiers keys+manageSequentialKeys :: (String -> K (String, Bool)) -> String -> K (String, Bool)+manageSequentialKeys handler keystroke = do+ keysRef <- getState "Hbro.Keys.manageSequentialKeys" "" + keys <- io $ manageSequentialKeys' keysRef keystroke+ (keys', result) <- handler keys case result of- True -> newHandler []- _ -> case newKey of- "<Escape>" -> newHandler []- _ -> newHandler keys+ True -> (io . modifyIORef keysRef $ const []) >> return ([], result)+ _ -> return (keys', result) --- | Convert a keyVal to a String.+manageSequentialKeys' :: IORef String -> String -> IO String+manageSequentialKeys' previousKeys "<Escape>" = do+ writeIORef previousKeys []+ return []+manageSequentialKeys' previousKeys keystroke = do+ modifyIORef previousKeys (++ keystroke)+ return =<< readIORef previousKeys+ +-- | Convert 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 wrapped into "< >" is returned. -- For modifiers, Nothing is returned.@@ -98,6 +72,13 @@ "dead_diaeresis" -> Just "¨" x -> Just ('<':x ++ ">") +-- | Convert a Modifier to a String. +stringify :: Modifier -> String+stringify Control = "C-"+--stringify' Shift = "S-"+stringify Alt = "M-"+stringify _ = []+ -- | Convert key bindings list to a map.-keysListToMap :: KeysList -> KeysMap-keysListToMap = M.fromList . (map (\((a,b),c) -> ((S.fromList a, b), c)))+-- keysListToMap :: KeysList -> KeysMap+-- keysListToMap = M.fromList . (map (\(a, b) -> ((S.fromList a, b), c)))
Hbro/Main.hs view
@@ -1,6 +1,7 @@ module Main where -- {{{ Imports+import Hbro.Config import Hbro.Hbro import Hbro.Types @@ -10,11 +11,8 @@ -- | Default main function provided as example. main :: IO () main = do--- putStrLn "[WARNING] You are running the default configuration which provides hardly no feature."--- putStrLn "[WARNING] You should copy the example configuration files hbro.hs and ui.xml in ~/.config/hbro/hbro and start hacking them."- uiFile <- getDataFileName "examples/ui.xml" - launchHbro $ \d -> (defaultConfig d) {- mUIFile = uiFile+ launchHbro $ defaultConfig {+ mUIFile = const uiFile }
+ Hbro/Prompt.hs view
@@ -0,0 +1,95 @@+module Hbro.Prompt where++-- {{{ Imports+import Hbro.Core+import Hbro.Types+import Hbro.Util++import Control.Monad hiding(forM_, mapM_)+--import Control.Monad.Trans++import Data.Foldable+import Data.IORef++import Graphics.Rendering.Pango.Enums+import Graphics.UI.Gtk.Abstract.Widget+import Graphics.UI.Gtk.Builder+import Graphics.UI.Gtk.Display.Label+import Graphics.UI.Gtk.Entry.Editable+import Graphics.UI.Gtk.Entry.Entry+import Graphics.UI.Gtk.Layout.HBox++import Network.URI++import Prelude hiding(mapM_)++import System.Console.CmdArgs (whenLoud)+-- }}}++init :: Builder -> IO PromptBar+init builder = do+ label <- builderGetObject builder castToLabel "promptDescription"+ labelSetAttributes label [allItalic, allBold]++ entry <- builderGetObject builder castToEntry "promptEntry"+ box <- builderGetObject builder castToHBox "promptBox"+ callbackRef <- newIORef (const $ return () :: String -> K ())+ incrementalCallbackRef <- newIORef (const $ return () :: String -> K ())+ + return $ PromptBar box label entry callbackRef incrementalCallbackRef++open :: String -> String -> K ()+open newDescription defaultText = with (mPromptBar . mGUI) $ \(PromptBar promptBox description entry _ _) -> do+ whenLoud . putStrLn $ "Opening prompt."+ labelSetText description newDescription+ entrySetText entry defaultText+ + widgetShow promptBox+ widgetGrabFocus entry+ editableSetPosition entry (-1)++-- | Close prompt, clean its content and callbacks+clean :: K ()+clean = with (mPromptBar . mGUI) $ \(PromptBar box _ entry cRef iRef) -> do+ widgetRestoreText entry StateNormal + widgetHide box+ writeIORef cRef (const $ return ())+ writeIORef iRef (const $ return ())+ + +-- | Open prompt bar with given description and default value,+-- and register a callback to trigger at validation.+read :: String -- ^ Prompt description+ -> String -- ^ Initial value+ -> (String -> K ()) -- ^ Callback function to trigger when validating prompt value+ -> K ()+read = read' False++-- | Same as 'prompt', but callback is triggered for each change in prompt's entry.+incrementalRead, iread :: String -> String -> (String -> K ()) -> K ()+incrementalRead = read' True+-- | Alias for incrementalRead.+iread = incrementalRead++read' :: Bool -> String -> String -> (String -> K ()) -> K ()+read' incremental description startValue callback = do+ open description startValue+ with (mPromptBar . mGUI) $ \promptBar -> case incremental of+ True -> writeIORef (mIncrementalCallbackRef promptBar) callback+ _ -> writeIORef (mCallbackRef promptBar) callback++-- | Same as "read" for URI values+readURI :: String -> String -> (URI -> K ()) -> K ()+readURI description startValue callback = withK (mPromptBar . mGUI) $ \promptBar -> do+ open description startValue+ checkURI startValue+ + io . writeIORef (mIncrementalCallbackRef promptBar) $ checkURI+ io . writeIORef (mCallbackRef promptBar) $ mapM_ callback . parseURIReference+ where+ checkURI value = with (mEntry . mPromptBar . mGUI) $ \entry -> do+ widgetModifyText entry StateNormal color+ where+ color = case isURIReference value of+ True -> Color 0 65535 0+ _ -> Color 65535 0 0
Hbro/Socket.hs view
@@ -1,137 +1,89 @@ module Hbro.Socket where -- {{{ Imports+import Hbro.Core hiding(getURI) import Hbro.Util import Hbro.Types +import Control.Concurrent import Control.Monad hiding(mapM_)-import Control.Monad.Reader hiding(mapM_) import Data.ByteString.Char8 (pack, unpack)-import Data.Foldable-import qualified Data.Map as Map--import Graphics.UI.Gtk.General.General-import Graphics.UI.Gtk.WebKit.WebView hiding(webViewGetUri, webViewLoadUri)--import Network.URI+--import Data.Foldable+import qualified Data.Map as M import Prelude hiding(mapM_) import System.Console.CmdArgs (whenNormal, whenLoud) import System.FilePath+import System.Posix.Process+import System.Posix.Types import System.ZMQ -- }}} --- | Create a response socket to listen for commands.--- Loops on listenToSocket until "Quit" command is received.-openRepSocket :: Context -> String -> (Socket Rep -> IO ()) -> IO ()-openRepSocket context socketURI listen = do - whenNormal $ putStrLn ("Opening socket at " ++ socketURI)- withSocket context Rep $ \repSocket -> do- bind repSocket socketURI- listen repSocket+-- | Open a response-socket at configured location, named hbro.<pid>, and start listening for commands +open :: K () +open = do+-- Resolve socket URI + pid <- io getProcessID+ socketURI <- with (mSocketDir . mConfig) $ resolve >=> (return . (socketFile pid))+-- Open socket and listen to commands+ mapK (void . forkIO) $ withK mContext $ \context -> do+ io . whenNormal . putStrLn . ("Opening socket at " ++) $ socketURI+ mapK2 (withSocket context Rep) $ \sock -> do+ io $ bind sock socketURI+ readCommands sock ++-- | Close the response socket by sending it the command "QUIT".+-- Typically called when exiting application. +close :: K ()+close = getURI >>= \uri -> do + (io . whenLoud . putStrLn . ("Closing socket " ++) . (++ " ...")) uri+ (void . (`sendCommand` "QUIT")) uri++ -- | Listen for incoming requests from response socket. -- Parse received commands and feed the corresponding callback, if any.-listenToCommands :: Environment -> CommandsMap -> Socket Rep -> IO ()-listenToCommands environment commands repSocket = do- message <- receive repSocket []- let message' = unpack message+readCommands :: Socket Rep -> K ()+readCommands sock = do+ message <- io $ unpack `fmap` receive sock [] - case words message' of+ case words message of -- Empty command- [] -> send repSocket (pack "ERROR Unknown command") []+ [] -> io $ send sock (pack "ERROR Unknown command") [] -- Exit command- ["QUIT"] -> do- whenLoud $ putStrLn "Receiving QUIT command"- send repSocket (pack "OK") []+ ["QUIT"] -> io $ do+ whenLoud . putStrLn $ "Receiving QUIT command"+ send sock (pack "OK") [] -- Valid command- command:arguments -> do- whenLoud $ putStrLn ("Receiving command: " ++ message')- case Map.lookup command commands of- Just callback -> callback arguments repSocket environment- _ -> send repSocket (pack "ERROR Unknown command") []+ command:arguments -> withK (M.fromList . mCommands . mConfig) $ \commands -> do+ io . whenLoud . putStrLn . ("Receiving command: " ++) $ message+ case M.lookup command commands of+ Just callback -> callback arguments >>= io . (send'' sock) . pack+ _ -> io $ send sock (pack "ERROR Unknown command") [] - listenToCommands environment commands repSocket+ readCommands sock --- | Close the response socket by sending it the command "QUIT".--- Typically called when exiting application. -closeSocket :: Context -> String -> IO ()-closeSocket context socketURI = void $ sendCommand context socketURI "QUIT"+getURI :: K String+getURI = with (mSocketDir . mConfig) $ \dir -> do+ dir' <- resolve dir+ (`socketFile` dir') `fmap` getProcessID -- | Return the socket path to use for the given browser's process ID.-socketFile :: String -> String -> String-socketFile pid socketDir = "ipc://" ++ socketDir </> "hbro." ++ pid+socketFile :: ProcessID -> String -> String+socketFile pid socketDir = "ipc://" ++ socketDir </> "hbro." ++ show pid -- | Send a single command (through a Request socket) to the given Response socket, -- and return the answer.-sendCommand :: Context -> String -> String -> IO String-sendCommand context socketURI command = withSocket context Req $ \reqSocket -> do- connect reqSocket socketURI- send reqSocket (pack command) []- receive reqSocket [] >>= return . unpack+sendCommand :: String -> String -> K String+sendCommand socketURI command = with mContext $ \context -> withSocket context Req $ \sock -> do+ connect sock socketURI+ send sock (pack command) []+ unpack `fmap` receive sock [] -- | Same as 'sendCommand', but for all running instances of the browser.-sendCommandToAll :: Context -> FilePath -> String -> IO [String]-sendCommandToAll context socketDir command = getAllProcessIDs >>= mapM (\pid -> sendCommand context (socketFile pid socketDir) command)---- | List of default supported requests.-defaultCommandsList :: CommandsList-defaultCommandsList = [- -- Get information- ("GET_URI", \_arguments repSocket browser -> liftIO $ do- getUri <- postGUISync $ webViewGetUri (mWebView $ mGUI browser)- case getUri of- Just uri -> send repSocket ((pack . show) uri) []- _ -> send repSocket (pack "ERROR No URL opened") [] ),-- ("GET_TITLE", \_arguments repSocket browser -> liftIO $ do- getTitle <- postGUISync $ webViewGetTitle (mWebView $ mGUI browser)- case getTitle of- Just title -> send repSocket (pack title) []- _ -> send repSocket (pack "ERROR No title") [] ),-- ("GET_FAVICON_URI", \_arguments repSocket browser -> liftIO $ do- getUri <- postGUISync $ webViewGetIconUri (mWebView $ mGUI browser)- case getUri of- Just uri -> send repSocket (pack uri) []- _ -> send repSocket (pack "ERROR No favicon uri") [] ),-- ("GET_LOAD_PROGRESS", \_arguments repSocket browser -> liftIO $ do- progress <- postGUISync $ webViewGetProgress (mWebView $ mGUI browser)- send repSocket (pack (show progress)) [] ),--- -- Trigger actions- ("LOAD_URI", \arguments repSocket browser -> liftIO $ case arguments of - uri:_ -> do- postGUIAsync $ mapM_ (webViewLoadUri (mWebView (mGUI browser))) (parseURIReference uri)- send repSocket (pack "OK") []- _ -> send repSocket (pack "ERROR: argument needed.") [] ),-- ("STOP_LOADING", \_arguments repSocket browser -> liftIO $do- postGUIAsync $ webViewStopLoading (mWebView $ mGUI browser) - send repSocket (pack "OK") [] ),-- ("RELOAD", \_arguments repSocket browser -> liftIO $ do- postGUIAsync $ webViewReload (mWebView $ mGUI browser)- send repSocket (pack "OK") [] ),-- ("GO_BACK", \_arguments repSocket browser -> liftIO $ do- postGUIAsync $ webViewGoBack (mWebView $ mGUI browser)- send repSocket (pack "OK") [] ),-- ("GO_FORWARD", \_arguments repSocket browser -> liftIO $ do- postGUIAsync $ webViewGoForward (mWebView $ mGUI browser)- send repSocket (pack "OK") [] ),-- ("ZOOM_IN", \_arguments repSocket browser -> liftIO $ do- postGUIAsync $ webViewZoomIn (mWebView $ mGUI browser)- send repSocket (pack "OK") [] ),-- ("ZOOM_OUT", \_arguments repSocket browser -> liftIO $ do- postGUIAsync $ webViewZoomOut (mWebView $ mGUI browser)- send repSocket (pack "OK") [] )- ]-+sendCommandToAll :: String -> K [String]+sendCommandToAll command = withK (mSocketDir . mConfig) $ \dir -> do+ dir' <- io $ resolve dir+ (io getAllProcessIDs) >>= mapM ((`sendCommand` command) . (`socketFile` dir'))
Hbro/Types.hs view
@@ -1,17 +1,24 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hbro.Types where -- {{{ Imports+import Control.Monad.Reader++import Data.Dynamic+import Data.IORef import Data.Map-import Data.Set+--import Data.Set import Graphics.UI.Gtk.Builder import Graphics.UI.Gtk.Display.Label import Graphics.UI.Gtk.Entry.Entry-import Graphics.UI.Gtk.Layout.HBox+import Graphics.UI.Gtk.General.General import Graphics.UI.Gtk.Gdk.EventM+import Graphics.UI.Gtk.Layout.HBox import Graphics.UI.Gtk.Scrolling.ScrolledWindow+import Graphics.UI.Gtk.WebKit.WebPolicyDecision import Graphics.UI.Gtk.WebKit.WebSettings import Graphics.UI.Gtk.WebKit.WebView import Graphics.UI.Gtk.Windows.Window@@ -20,83 +27,123 @@ import System.Console.CmdArgs import System.Glib.Attributes-import System.Glib.Signals+--import System.Glib.Signals import System.ZMQ -- }}} +-- | Base type for high-level actions, mnemonics: K(it) from WebKit+type K = KT IO --- | Various directories used to store some runtime and static files.-data CommonDirectories = CommonDirectories {- mHome :: FilePath, -- ^ Home directory- mTemporary :: FilePath, -- ^ Temporary files directory- mConfiguration :: FilePath, -- ^ Configuration directory- mData :: FilePath -- ^ Data directory-}- --- | The whole set of parameters and elements of the browser.+newtype KT m a = KT (ReaderT Environment m a)+ deriving (Functor, Monad, MonadFix, MonadIO, MonadReader Environment, MonadTrans)++-- | The whole set of parameters, elements and states of the application data Environment = Environment {- mOptions :: CliOptions, -- ^ Commandline options- mConfig :: Config, -- ^ Configuration parameters (constants) provided by user- mGUI :: GUI, -- ^ Graphical widgets- mContext :: Context -- ^ ZMQ context+ mState :: IORef (Map String Dynamic), -- ^ + mOptions :: CliOptions, -- ^ Commandline options+ mConfig :: Config, -- ^ Custom configuration provided by user+ mGUI :: GUI, -- ^ Graphical widgets+ mContext :: Context -- ^ ZeroMQ context } --- | Supported commandline options+-- | Set of commandline options data CliOptions = CliOptions {- mURI :: Maybe String, -- ^ URI to load at start-up- mVanilla :: Bool, -- ^ Bypass custom configuration file- mDenyReconf :: Bool, -- ^ Do not recompile browser even if configuration file has changed- mForceReconf :: Bool, -- ^ Force recompilation even if configuration file hasn't changed- mDyreDebug :: Bool, -- ^ Look for a custom configuration file in working directory- mMasterBinary :: Maybe String -- ^ + mURI :: Maybe String, -- ^ URI to load at start-up+ mVanilla :: Bool, -- ^ Bypass custom configuration file+ mRecompile :: Bool, -- ^ Force recompilation and do not launch browser+ mDenyReconf :: Bool, -- ^ Do not recompile browser even if configuration file has changed+ mForceReconf :: Bool, -- ^ Force recompilation even if configuration file hasn't changed+ mDyreDebug :: Bool, -- ^ Look for a custom configuration file in current working directory+ mMasterBinary :: Maybe String -- ^ Path to the master binary, used by Dyre } deriving (Data, Typeable, Show, Eq) --data Config = {-forall a.-} Config {- mCommonDirectories :: CommonDirectories, -- ^ Custom directories used to store various runtime and static files+-- | Custom parameters provided by the user+data Config = Config {+ --mCommonDirectories :: CommonDirectories, -- ^ Custom directories used to store various runtime and static files+ mSocketDir :: RefDirs -> FilePath, -- ^ Directory where 0MQ sockets will be created ("/tmp" for example)+ mUIFile :: RefDirs -> FilePath, -- ^ Path to XML file describing UI (used by GtkBuilder) mHomePage :: String, -- ^ Startup page - mSocketDir :: FilePath, -- ^ Directory where 0MQ will be created ("/tmp" for example)- mUIFile :: FilePath, -- ^ Path to XML file describing UI (used by GtkBuilder)- mKeyEventHandler :: KeyEventCallback -> ConnectId WebView -> WebView -> EventM EKey Bool, -- ^ Key event handler, which forwards keystrokes to mKeyEventCallback- mKeyEventCallback :: Environment -> KeyEventCallback, -- ^ Main key event callback, assumed to deal with each keystroke separately mWebSettings :: [AttrOp WebSettings], -- ^ WebSettings' attributes to use with webkit (see Webkit.WebSettings documentation)- mSetup :: Environment -> IO (), -- ^ Custom startup instructions- mCommands :: CommandsList, -- ^ Custom commands to use with IPC sockets- mDownloadHook :: Environment -> URI -> String -> Int -> IO (), -- ^ Function triggered on a download request- mError :: Maybe String -- ^ Error- --mCustom :: a+-- mKeyEventHandler :: KeyEventCallback -> ConnectId WebView -> WebView -> EventM EKey Bool, -- ^ Key event handler, which forwards keystrokes to mKeyEventCallback+-- mKeyEventCallback :: Environment -> KeyEventCallback, -- ^ Main key event callback, assumed to deal with each keystroke separately+ mCommands :: CommandsList, -- ^ Commands recognized through 0MQ sockets+ mHooks :: Hooks -- ^ Set of functions triggered on specific events } +type Config' = Either String Config+++-- | Set of functions to be triggered when some events occur+data Hooks = Hooks {+ mBackForward :: URI -> WebPolicyDecision -> K (), -- ^ Previous/next page has been requested+ mDownload :: URI -> String -> Int -> K (), -- ^ A download has been requested+ mFormResubmitted :: URI -> WebPolicyDecision -> K(), -- ^ A form has been resubmitted+ mFormSubmitted :: URI -> WebPolicyDecision -> K (), -- ^ A form has been submitted+ mKeyPressed :: String -> K (), -- ^ + mLinkClicked :: Button -> URI -> WebPolicyDecision -> K (), -- ^ A link has been clicked+ mLoadFinished :: K (), -- ^ Load has finished+ mMIMEDisposition :: URI -> String -> WebPolicyDecision -> K (),+ mNewWindow :: URI -> K (), -- ^ A new window has been requested+ mOtherNavigation :: URI -> WebPolicyDecision -> K (), -- ^ + mReload :: URI -> WebPolicyDecision -> K (), -- ^ A reload of the current page has been requested+ mStartUp :: K (), -- ^ At start-up+ mTitleChanged :: String -> K () -- ^ Title has changed+}++-- | Graphical elements data GUI = GUI { mWindow :: Window, -- ^ Main window- mInspectorWindow :: Window, -- ^ WebInspector window+ mInspectorWindow :: Window, -- ^ Web-inspector window mScrollWindow :: ScrolledWindow, -- ^ ScrolledWindow containing the webview mWebView :: WebView, -- ^ Browser's webview mPromptBar :: PromptBar, -- ^ Prompt bar mStatusBar :: HBox, -- ^ Status bar's horizontal box+ mNotificationBar :: NotificationBar, -- ^ Bar used to display various notifications mBuilder :: Builder -- ^ Builder object created from XML file } +-- | Prompt-bar elements data PromptBar = PromptBar {- mBox :: HBox,- mDescription :: Label, -- ^ Description of current prompt- mEntry :: Entry -- ^ Prompt entry+ mBox :: HBox, -- ^ Layout box+ mDescription :: Label, -- ^ Description of current prompt+ mEntry :: Entry, -- ^ Prompt entry+ mCallbackRef :: IORef (String -> K ()), -- ^+ mIncrementalCallbackRef :: IORef (String -> K ()) -- ^ } +-- | Notification-bar elements+data NotificationBar = NotificationBar {+ mLabel :: Label, -- ^ Content+ mTimer :: IORef (Maybe HandlerId) -- ^ Timer handler+} --- | List of bound keys.--- All callbacks are fed with the Environment instance.--- +-- | Set of reference directories, typically used to build FilePath-s+data RefDirs = RefDirs {+ mHome :: FilePath, -- ^ Home directory+ mTemporary :: FilePath, -- ^ Temporary files directory+ mConfiguration :: FilePath, -- ^ Configuration directory+ mData :: FilePath -- ^ Data directory+}++type PortableFilePath = RefDirs -> FilePath+ -- Note 1 : for modifiers, lists are used for convenience purposes, -- but are transformed into sets in hbro's internal machinery, -- so that order and repetition don't matter.--- --- Note 2 : for printable characters accessed via the shift modifier,--- you do have to include Shift in modifiers list.-type KeysList = [(([Modifier], String), IO ())]-type KeysMap = Map (Set Modifier, String) (IO ())+-- | List of bound keys.+-- All callbacks are fed with the Environment instance.+type KeysList = [(String, K ())]+type KeysMap = Map String (K ()) type KeyEventCallback = [Modifier] -> String -> IO Bool --data KeyMode = CommandMode | InsertMode -type CommandsList = [(String, ([String] -> Socket Rep -> Environment -> IO ()))]-type CommandsMap = Map String ([String] -> Socket Rep -> Environment -> IO ())+type CommandsList = [(String, ([String] -> K String))]+type CommandsMap = Map String ([String] -> K String)++-- |+data Button = ButtonL | ButtonM | ButtonR++-- Boolean datatypes+data CaseSensitivity = CaseSensitive | CaseInsensitive+data Direction = Forward | Backward+data Wrap = Wrap | NoWrap
Hbro/Util.hs view
@@ -1,42 +1,69 @@ module Hbro.Util (+-- * General purpose+ io,+ resolve, -- * Process management spawn, getAllProcessIDs,--- * WebKit functions redefinition- webFrameGetUri,- webViewGetUri,- webViewLoadUri,+-- * Boolean data-types conversion+ isCaseSensitive,+ isForward,+ isWrapped,+-- * Common pango attributes+ allItalic,+ allBold, -- * Misc+ send'', labelSetMarkupTemporary, dmenu, errorHandler ) where -- {{{ Imports---import Hbro.Types+import Hbro.Types +import Control.Exception --import Control.Monad.Reader import Control.Monad+import Control.Monad.IO.Class +import Data.ByteString (ByteString)+--import Data.IORef import Data.List-import Data.IORef +import Graphics.Rendering.Pango.Enums import Graphics.UI.Gtk.Display.Label import Graphics.UI.Gtk.General.General-import qualified Graphics.UI.Gtk.WebKit.WebFrame as WebKit-import qualified Graphics.UI.Gtk.WebKit.WebView as WebKit -import Network.URI- import System.Console.CmdArgs+import System.Directory+import System.Environment.XDG.BaseDir import qualified System.Info as Sys import System.IO-import System.IO.Error+import System.IO.Error hiding(try) import System.Posix.Process+import System.Posix.Types import System.Process+import System.ZMQ -- }}} +io :: MonadIO m => IO a -> m a+io = liftIO++send'' :: Socket a -> ByteString -> IO ()+send'' x y = send x y []++-- |+resolve :: (RefDirs -> a) -> IO a+resolve f = do+ homeDir <- getHomeDirectory+ tmpDir <- getTemporaryDirectory+ configDir <- getUserConfigDir "hbro"+ dataDir <- getUserDataDir "hbro"+ + return . f $ RefDirs homeDir tmpDir configDir dataDir+ -- {{{ Process management -- | Run external command and won't kill when parent process exit. spawn :: String -> [String] -> IO ()@@ -46,31 +73,13 @@ spawn' command = createProcess command { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe, close_fds = True } >> return () -- | Return the list of process IDs corresponding to all running instances of the browser.-getAllProcessIDs :: IO [FilePath]+getAllProcessIDs :: IO [ProcessID] getAllProcessIDs = do (_, pids, _) <- readProcessWithExitCode "pidof" ["hbro"] [] (_, pids', _) <- readProcessWithExitCode "pidof" ["hbro-" ++ Sys.os ++ "-" ++ Sys.arch] [] myPid <- getProcessID - return $ delete (show myPid) . nub . words $ pids ++ " " ++ pids'--- }}}---- {{{ Webkit functions redefinition--- | Replacement for Graphics.UI.Gtk.WebKit.WebFrame(webFrameGetUri), using the Network.URI type.-webFrameGetUri :: WebKit.WebFrame -> IO (Maybe URI)-webFrameGetUri frame = (>>= parseURI) `fmap` WebKit.webFrameGetUri frame---- | Replacement for Graphics.UI.Gtk.WebKit.WebView(webViewGetUri), using the Network.URI type.-webViewGetUri :: WebKit.WebView -> IO (Maybe URI)-webViewGetUri webView = (>>= parseURI) `fmap` WebKit.webViewGetUri webView---- | Replacement for Graphics.UI.Gtk.WebKit.WebView(webViewLoadUri), using the Network.URI type.-webViewLoadUri :: WebKit.WebView -> URI -> IO ()-webViewLoadUri webView uri = do- whenLoud $ putStrLn ("Loading URI: " ++ show uri)- case uriScheme uri of- [] -> WebKit.webViewLoadUri webView ("http://" ++ show uri)- _ -> WebKit.webViewLoadUri webView (show uri)+ return $ delete myPid . map (read :: String -> ProcessID) . nub . words $ pids ++ " " ++ pids' -- }}} -- | Set a temporary markup text to a label that disappears after some delay.@@ -93,7 +102,7 @@ hPutStr in_ input hClose in_ - output <- try $ hGetLine out + output <- try $ hGetLine out :: IO (Either IOError String) let output' = case output of Left _ -> Nothing Right x -> Just x@@ -106,3 +115,22 @@ when (isAlreadyInUseError e) $ (whenNormal . putStrLn) ("ERROR: file <" ++ file ++ "> is already opened and cannot be reopened.") when (isDoesNotExistError e) $ (whenNormal . putStrLn) ("ERROR: file <" ++ file ++ "> doesn't exist.") when (isPermissionError e) $ (whenNormal . putStrLn) ("ERROR: user doesn't have permission to open file <" ++ file ++ ">.")++-- Boolean types conversion+isCaseSensitive :: CaseSensitivity -> Bool+isCaseSensitive CaseSensitive = True+isCaseSensitive _ = False++isForward :: Direction -> Bool+isForward Forward = True+isForward _ = False++isWrapped :: Wrap -> Bool+isWrapped Wrap = True+isWrapped _ = False++-- Common pango attributes+allItalic, allBold :: PangoAttribute+allItalic = AttrStyle {paStart = 0, paEnd = -1, paStyle = StyleItalic}+allBold = AttrWeight {paStart = 0, paEnd = -1, paWeight = WeightBold}+
README.rst view
@@ -3,7 +3,7 @@ ==== -**In a nutshell**: *hbro* is a minimal KISS compliant browser written in Haskell and for linux, still in development but pretty usable.+**In a nutshell**: *hbro* is a minimal KISS compliant browser for linux written and configured in Haskell, still in development but pretty usable. Informations about versions, dependencies, source repositories and contacts can be found in hackage_. @@ -57,33 +57,10 @@ Apart from the programming language, if you happen to find a better alternative for one of these points, please note that suggestions are more than welcome :) . -.. How to install it ?- -------------------- - Please note that despite being written in a multiplatform language, *hbro* will only run under a linux environment.- - The simplest way is using the haskell packaging system::- - cabal install hbro- - Alternatively, you can download the hbro package from hackage, and install it with cabal-install.---.. Where to get the source ?- -------------------------- - The latest source is hosted:- - * on github: ``git@github.com:k0ral/hbro.git``- * on a personal server, which is unfortunately shutdown every european night: ``git://twyk.org/haskell-browser.git``- - You can still retrieve the source from hackage at any time, however the very last commits may not be included.-- Configuration ------------- -By default, a pretty limited configuration file (see ``Hbro/Main.hs``) is used to build *hbro*. You can create your own at ``~/.config/hbro/hbro.hs`` to override it. Several extensions are provided with the *hbro-contrib_* package, including a featured and self-explanatory example of configuration file.+By default, a pretty limited configuration file (see ``Hbro/Main.hs``) is used to build *hbro*. You can create your own at ``~/.config/hbro/hbro.hs`` to override it. Several extensions are provided with the * hbro-contrib_ * package, including a featured and self-explanatory example of configuration file. Known bugs and limitations@@ -94,8 +71,8 @@ Flash videos make hbro freeze The demo webkit browser for haskell's binding has the same problem, so it doesn't seem to come from hbro itself. -Javascript's window.open requests open in the same window instead of spawning a new one.- This is due to this webkit's bug.+.. Javascript's window.open requests open in the same window instead of spawning a new one.+ This is due to this webkit's bug. When toggling to source mode, current webpage is reloaded This is an undesired behavior since the webpage may have changed after reloading; webkit's API allows to get the content of the DOM but only inside the body tag; it is also possible to store the HTML source as it is downloaded, but then any further change in the DOM (for example triggered by javascript functions) wouldn't be visible.
examples/ui.xml view
@@ -39,13 +39,34 @@ <object class="GtkHBox" id="statusBox"> <property name="homogeneous">False</property> <property name="spacing">5</property>-+ <child> <object class="GtkLabel" id="void"></object> <packing> <property name="fill">False</property> <property name="expand">False</property> </packing>+ </child>+ </object>++ <packing>+ <property name="fill">False</property>+ <property name="expand">False</property>+ </packing>+ </child>+++ <!-- Notify bar -->+ <child>+ <object class="GtkHBox" id="notificationBox">+ <property name="homogeneous">False</property>+ <property name="spacing">5</property>+ + <child>+ <object class="GtkLabel" id="notificationLabel">+ <property name="single-line-mode">True</property>+ <property name="xalign">0</property>+ </object> </child> </object>
hbro.cabal view
@@ -1,6 +1,6 @@ Name: hbro-Version: 0.8.0.0-Synopsis: A minimal KISS compliant browser+Version: 0.9.0.0+Synopsis: Minimal KISS compliant browser -- Description: Homepage: http://projects.haskell.org/hbro/ Category: Browser,Web@@ -38,15 +38,18 @@ network, pango, process,+ transformers, unix, webkit, xdg-basedir, zeromq-haskell Exposed-modules:+ Hbro.Config, Hbro.Core, Hbro.Gui, Hbro.Hbro, Hbro.Keys,+ Hbro.Prompt, Hbro.Socket, Hbro.Types, Hbro.Util