hbro 0.4.6 → 0.5.0
raw patch · 6 files changed
+260/−147 lines, 6 filesdep +cmdargsdep −glade
Dependencies added: cmdargs
Dependencies removed: glade
Files
- Hbro/Core.hs +68/−54
- Hbro/Gui.hs +26/−48
- Hbro/Socket.hs +19/−11
- examples/Main.hs +50/−19
- examples/ui.xml +86/−0
- hbro.cabal +11/−15
Hbro/Core.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} module Hbro.Core where -- {{{ Imports@@ -13,15 +13,13 @@ import qualified Data.Map as Map import qualified Data.Set as Set -import Graphics.UI.Gtk.Abstract.Box import Graphics.UI.Gtk.Abstract.Container-import Graphics.UI.Gtk.Abstract.IMContext+--import Graphics.UI.Gtk.Abstract.IMContext import Graphics.UI.Gtk.Abstract.Widget-import Graphics.UI.Gtk.Display.Label 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.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@@ -30,59 +28,77 @@ import Network.URL import Prelude -import System.Environment-import System.Glib.Attributes+import System.Console.CmdArgs+--import System.Glib.Attributes import System.Glib.Signals import System.Posix.Process -- }}} -- {{{ Type definitions data Browser = Browser {- mArgs :: [String],- mGUI :: GUI+ mOptions :: CliOptions, -- ^ Commandline options+ mGUI :: GUI -- ^ Graphical widgets } -type KeyBindingsList = [(([Modifier], String), (GUI -> IO ()))]- data Configuration = Configuration { mHomePage :: String, -- ^ Startup page - mSocketDir :: String, -- ^ Path to socket directory (/tmp for example)+ 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"+}++getOptions :: IO CliOptions+getOptions = cmdArgs $ cliOptions+ &= verbosityArgs [explicit, name "Verbose", name "v"] []+ &= versionArg [ignore]+ &= help "A suckless minimal KISSy browser."+ &= helpArg [explicit, name "help", name "h"]+ &= program "hbro"+-- }}}+ -- {{{ Entry point -- | Entry point of the application.--- Check if help display is requested.+-- | Parse arguments and step down in favour of initBrowser. realMain :: Configuration -> IO () realMain configuration = do- args <- getArgs-- case args of- ["--help"] -> putStrLn "Usage: browser [url]"- _ -> initBrowser configuration+ options <- getOptions+ initBrowser configuration options -- }}} -- {{{ Main function -- | Application's main function. -- Create browser and load homepage.-initBrowser :: Configuration -> IO ()-initBrowser configuration = do+initBrowser :: Configuration -> CliOptions -> IO ()+initBrowser configuration options = do+ -- Print configuration error, if any case (mError configuration) of- Just error -> putStrLn error- _ -> return ()+ Just e -> putStrLn e+ _ -> return () -- Initialize browser- args <- initGUI- gui <- loadGUI ""- let browser = Browser args gui+ _ <- initGUI+ gui <- loadGUI (mUIFile configuration)+ --let browser = Browser options gui -- Initialize IPC socket pid <- getProcessID- _ <- forkOS $ createReplySocket ("ipc://" ++ (mSocketDir configuration) ++ "/hbro." ++ show pid) gui+ _ <- forkIO $ createReplySocket ("ipc://" ++ (mSocketDir configuration) ++ "/hbro." ++ show pid) gui -- Load configuration settings <- mWebSettings configuration@@ -92,9 +108,9 @@ (mAtStartUp configuration) gui -- Load url- let url = case args of- [arg] -> arg- _ -> mHomePage configuration+ let url = case (mURI options) of+ Just x -> x+ _ -> mHomePage configuration loadURL url gui @@ -134,25 +150,25 @@ -- TODO: when does this signal happen ?! --_ <- on inspector finished $ return () - _ <- on inspector attachWindow $ do- getWebView <- webInspectorGetWebView inspector- case getWebView of- Just webView -> do widgetHide (mInspectorWindow gui)- containerRemove (mInspectorWindow gui) webView- widgetSetSizeRequest webView (-1) 250- boxPackEnd (mWindowBox gui) webView PackNatural 0- widgetShow webView- return True- _ -> return False+-- _ <- on inspector attachWindow $ do+-- getWebView <- webInspectorGetWebView inspector+-- case getWebView of+-- Just webView -> do widgetHide (mInspectorWindow gui)+-- containerRemove (mInspectorWindow gui) webView+-- widgetSetSizeRequest webView (-1) 250+-- boxPackEnd (mWindowBox gui) webView PackNatural 0+-- widgetShow webView+-- return True+-- _ -> return False - _ <- on inspector detachWindow $ do- getWebView <- webInspectorGetWebView inspector- _ <- case getWebView of- Just webView -> do containerRemove (mWindowBox gui) webView- containerAdd (mInspectorWindow gui) webView- widgetShowAll (mInspectorWindow gui)- return True- _ -> return False+-- _ <- on inspector detachWindow $ do+-- getWebView <- webInspectorGetWebView inspector+-- _ <- case getWebView of+-- Just webView -> do containerRemove (mWindowBox gui) webView+-- containerAdd (mInspectorWindow gui) webView+-- widgetShowAll (mInspectorWindow gui)+-- return True+-- _ -> return False widgetShowAll (mInspectorWindow gui) return True@@ -180,10 +196,8 @@ case keyString of Just string -> do case Map.lookup (Set.fromList modifiers, string) keyBindings of- Just callback -> do- liftIO $ callback gui- liftIO $ labelSetMarkup (mKeysLabel gui) $ "<span foreground=\"green\">" ++ show modifiers ++ string ++ "</span>"- _ -> liftIO $ putStrLn string + Just callback -> liftIO $ callback gui+ _ -> liftIO $ putStrLn string _ -> return () return False@@ -241,8 +255,8 @@ showError :: Configuration -> String -> Configuration showError configuration message = configuration { mError = Just message } -browser :: Configuration -> IO ()-browser = Dyre.wrapMain Dyre.defaultParams {+hbro :: Configuration -> IO ()+hbro = Dyre.wrapMain Dyre.defaultParams { Dyre.projectName = "hbro", Dyre.showError = showError, Dyre.realMain = realMain,
Hbro/Gui.hs view
@@ -4,10 +4,21 @@ -- {{{ Imports import Control.Monad.Trans(liftIO) -import Graphics.UI.Gtk --import Graphics.UI.Gtk.Abstract.Misc-import Graphics.UI.Gtk.Glade+import Graphics.UI.Gtk.Abstract.Container+import Graphics.UI.Gtk.Abstract.Widget+import Graphics.UI.Gtk.Builder+import Graphics.UI.Gtk.Display.Label+import Graphics.UI.Gtk.Entry.Editable+import Graphics.UI.Gtk.Entry.Entry+import Graphics.UI.Gtk.General.General+import Graphics.UI.Gtk.Gdk.EventM+import Graphics.UI.Gtk.Scrolling.ScrolledWindow import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.Windows.Window++import System.Glib.Attributes+import System.Glib.Signals -- }}} data GUI = GUI {@@ -17,59 +28,29 @@ mWebView :: WebView, -- ^ Browser's webview mPromptLabel :: Label, -- ^ Description of current prompt mPrompt :: Entry, -- ^ Prompt entry- mWindowBox :: VBox, -- ^ Window's layout- mStatusBox :: HBox, -- ^ Status bar's layout- mProgressLabel :: Label,- mUrlLabel :: Label,- mKeysLabel :: Label,- mScrollLabel :: Label+ mBuilder :: Builder -- ^ Builder object created from XML file } --- {{{ Load glade GUI--- | Load GUI from a glade file.+-- {{{ Load GUI from XML file loadGUI :: String -> IO GUI-loadGUI gladePath = do- -- Note: crashes with a runtime error on console if fails!--- Just xml <- xmlNew gladePath+loadGUI xmlPath = do+ builder <- builderNew+ builderAddFromFile builder xmlPath --- -- Load main window--- -- castTo* don't exist :(--- window <- xmlGetWidget xml castToWindow "window"--- webView <- xmlGetWidget xml castToWebView "webView"--- promptLabel <- xmlGetWidget xml castToLabel "promptLabel"--- prompt <- xmlGetWidget xml castToEntry "prompt"+ -- Load main window+ window <- builderGetObject builder castToWindow "mainWindow"+ scrollWindow <- builderGetObject builder castToScrolledWindow "webViewParent"+ promptLabel <- builderGetObject builder castToLabel "promptDescription"+ promptEntry <- builderGetObject builder castToEntry "promptEntry" - window <- windowNew inspectorWindow <- windowNew --windowSetDefaultSize window 1024 768- windowSetPosition window WinPosCenter+ --windowSetPosition window WinPosCenter --windowSetIconFromFile window "/path/to/icon" set window [ windowTitle := "hbro" ] - webView <- webViewNew- winBox <- vBoxNew False 0- promptBox <- hBoxNew False 10- statusBox <- hBoxNew False 5- scrollWindow <- scrolledWindowNew Nothing Nothing- promptLabel <- labelNew Nothing- promptEntry <- entryNew- progressLabel <- labelNew (Just "0%")- urlLabel <- labelNew Nothing- keysLabel <- labelNew Nothing- scrollLabel <- labelNew (Just "0%")-- boxPackStart winBox scrollWindow PackGrow 0- boxPackStart winBox promptBox PackNatural 0- boxPackStart winBox statusBox PackNatural 0- boxPackStart promptBox promptLabel PackNatural 0- boxPackStart promptBox promptEntry PackGrow 0- boxPackStart statusBox progressLabel PackNatural 0- boxPackStart statusBox urlLabel PackGrow 0- boxPackEnd statusBox scrollLabel PackNatural 0- boxPackEnd statusBox keysLabel PackNatural 0- - containerAdd window winBox+ webView <- webViewNew containerAdd scrollWindow webView set webView [ widgetCanDefault := True ]@@ -78,14 +59,11 @@ scrolledWindowHscrollbarPolicy := PolicyNever, scrolledWindowVscrollbarPolicy := PolicyNever ] - labelSetEllipsize urlLabel EllipsizeEnd- miscSetAlignment urlLabel 0 0- _ <- on webView closeWebView $ do mainQuit return True - return $ GUI window inspectorWindow scrollWindow webView promptLabel promptEntry winBox statusBox progressLabel urlLabel keysLabel scrollLabel+ return $ GUI window inspectorWindow scrollWindow webView promptLabel promptEntry builder -- }}} -- {{{ Prompt
Hbro/Socket.hs view
@@ -5,6 +5,7 @@ import Control.Monad import Data.ByteString.Char8 (pack, unpack)+import Graphics.UI.Gtk.General.General import Graphics.UI.Gtk.WebKit.WebView import System.ZMQ -- }}}@@ -13,50 +14,57 @@ createReplySocket socketName gui = withContext 1 $ \context -> do withSocket context Rep $ \socket -> do bind socket socketName++ postGUIAsync $ do+ quitAdd 0 $ do+ close socket+ return False+ return ()+ forever $ do command <- receive socket [] case unpack command of -- Get information "getUri" -> do- getUri <- webViewGetUri (mWebView gui)+ getUri <- postGUISync $ webViewGetUri (mWebView gui) case getUri of Just uri -> send socket (pack uri) [] _ -> send socket (pack "ERROR No URL opened") [] "getTitle" -> do- getTitle <- webViewGetTitle (mWebView gui)+ getTitle <- postGUISync $ webViewGetTitle (mWebView gui) case getTitle of Just title -> send socket (pack title) [] _ -> send socket (pack "ERROR No title") [] "getFaviconUri" -> do- getUri <- webViewGetIconUri (mWebView gui)+ getUri <- postGUISync $ webViewGetIconUri (mWebView gui) case getUri of Just uri -> send socket (pack uri) [] _ -> send socket (pack "ERROR No favicon uri") [] "getLoadProgress" -> do- progress <- webViewGetProgress (mWebView gui)+ progress <- postGUISync $ webViewGetProgress (mWebView gui) send socket (pack (show progress)) [] -- Trigger actions ('l':'o':'a':'d':'U':'r':'i':' ':uri) -> do- webViewLoadUri (mWebView gui) uri+ postGUIAsync $ webViewLoadUri (mWebView gui) uri send socket (pack "OK") [] "stopLoading" -> do- webViewStopLoading (mWebView gui) + postGUIAsync $ webViewStopLoading (mWebView gui) send socket (pack "OK") [] "reload" -> do- webViewReload (mWebView gui)+ postGUIAsync $ webViewReload (mWebView gui) send socket (pack "OK") [] "goBack" -> do- webViewGoBack (mWebView gui)+ postGUIAsync $ webViewGoBack (mWebView gui) send socket (pack "OK") [] "goForward" -> do- webViewGoForward (mWebView gui)+ postGUIAsync $ webViewGoForward (mWebView gui) send socket (pack "OK") [] "zoomIn" -> do- webViewZoomIn (mWebView gui)+ postGUIAsync $ webViewZoomIn (mWebView gui) send socket (pack "OK") [] "zoomOut" -> do- webViewZoomOut (mWebView gui)+ postGUIAsync $ webViewZoomOut (mWebView gui) send socket (pack "OK") [] _ -> send socket (pack "ERROR Unknown command") []
examples/Main.hs view
@@ -5,9 +5,12 @@ import Hbro.Gui import Hbro.Util +import Control.Monad.Trans(liftIO)+ import Graphics.Rendering.Pango.Layout import Graphics.UI.Gtk.Abstract.Widget+import Graphics.UI.Gtk.Builder import Graphics.UI.Gtk.Display.Label import Graphics.UI.Gtk.Entry.Entry import Graphics.UI.Gtk.Gdk.EventM@@ -22,6 +25,9 @@ import Graphics.UI.Gtk.WebKit.WebSettings import Graphics.UI.Gtk.Windows.Window +-- import Paths_hbro -- Doesn't work for now++import System.Environment import System.Glib.Attributes import System.Glib.Signals import System.Process @@ -29,25 +35,35 @@ -- }}} main :: IO ()-main = browser Configuration {+main = do+ --uiFile <- getDataFileName "examples/ui.xml" -- Doesn't work for now+ configHome <- getEnv "XDG_CONFIG_HOME"+ + hbro Configuration { -- Do not change this mError = Nothing, -- Directory where 0MQ sockets will be created 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",+ -- URI loaded at startup mHomePage = "https://www.google.com", -- Custom keys+ -- All callbacks are fed with the GUI instance -- 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,+ -- Note 3 : for printable characters accessed via the shift modifier, -- you do have to include Shift in modifiers list mKeyBindings = [--- ((Modifiers, Key), Callback)+-- ((modifiers, key), callback) -- Browse (([], "<"), goBack), (([Shift], ">"), goForward),@@ -59,9 +75,13 @@ (([], "<Home>"), verticalHome), (([], "<End>"), verticalEnd), - -- Zoom+ -- Display (([Shift], "+"), zoomIn), (([], "-"), zoomOut),+ (([], "<F11>"), fullscreen),+ (([], "<Escape>"), unfullscreen),+ (([], "t"), toggleStatusBar),+ (([Control], "u"), toggleSourceMode), -- Prompt (([], "o"), promptURL False), @@ -84,11 +104,7 @@ -- Others (([Control], "i"), showWebInspector),- (([Control], "u"), toggleSourceMode),- (([], "t"), toggleStatusBar),- (([Control], "p"), printPage),- (([], "<F11>"), fullscreen),- (([], "<Escape>"), unfullscreen)+ (([Control], "p"), printPage) ], @@ -144,13 +160,16 @@ -- Custom callbacks mAtStartUp = \gui -> (let+ builder = mBuilder gui webView = mWebView gui scrollWindow = mScrollWindow gui- progressLabel = mProgressLabel gui- urlLabel = mUrlLabel gui- scrollLabel = mScrollLabel gui window = mWindow gui in do+ progressLabel <- builderGetObject builder castToLabel "progress"+ uriLabel <- builderGetObject builder castToLabel "uri"+ scrollLabel <- builderGetObject builder castToLabel "scroll"+ keysLabel <- builderGetObject builder castToLabel "keys"+ -- Default background (for status bar) widgetModifyBg window StateNormal (Color 0 0 10000) @@ -166,6 +185,18 @@ 0 -> labelSetMarkup scrollLabel "ALL" x -> labelSetMarkup scrollLabel $ show (round $ current/x*100) ++ "%" + -- Pressed keys in statusbar+ _ <- after webView keyPressEvent $ do+ value <- eventKeyVal+ modifiers <- eventModifier++ let keyString = keyToString value+ case keyString of + Just string -> liftIO $ labelSetMarkup keysLabel $ "<span foreground=\"green\">" ++ show modifiers ++ string ++ "</span>"+ _ -> return ()++ return False+ -- Page load _ <- on webView loadStarted $ \_ -> do labelSetMarkup progressLabel "<span foreground=\"red\">0%</span>"@@ -173,8 +204,8 @@ _ <- on webView loadCommitted $ \_ -> do getUri <- (webViewGetUri webView) case getUri of - Just uri -> labelSetMarkup urlLabel $ "<span weight=\"bold\" foreground=\"white\">" ++ escapeMarkup uri ++ "</span>"- _ -> labelSetMarkup urlLabel "<span weight=\"bold\" foreground=\"red\">ERROR</span>"+ Just uri -> labelSetMarkup uriLabel $ "<span weight=\"bold\" foreground=\"white\">" ++ escapeMarkup uri ++ "</span>"+ _ -> labelSetMarkup uriLabel "<span weight=\"bold\" foreground=\"red\">ERROR</span>" _ <- on webView progressChanged $ \progress' -> labelSetMarkup progressLabel $ "<span foreground=\"yellow\">" ++ show progress' ++ "%</span>"@@ -226,7 +257,7 @@ Just uri -> case mouseButton of 1 -> return False -- Left button - 2 -> runExternalCommand ("hbro \"" ++ uri ++ "\"") >> return True -- Middle button+ 2 -> runExternalCommand ("hbro -u \"" ++ uri ++ "\"") >> return True -- Middle button 3 -> return False -- Right button _ -> return False -- No mouse button pressed _ -> return False@@ -245,8 +276,8 @@ _ <- on webView hoveringOverLink $ \title hoveredUri -> do getUri <- (webViewGetUri webView) case (hoveredUri, getUri) of- (Just u, _) -> labelSetMarkup urlLabel $ "<span foreground=\"#5555ff\">" ++ escapeMarkup u ++ "</span>"- (_, Just u) -> labelSetMarkup urlLabel $ "<span foreground=\"white\" weight=\"bold\">" ++ escapeMarkup u ++ "</span>"+ (Just u, _) -> labelSetMarkup uriLabel $ "<span foreground=\"#5555ff\">" ++ escapeMarkup u ++ "</span>"+ (_, Just u) -> labelSetMarkup uriLabel $ "<span foreground=\"white\" weight=\"bold\">" ++ escapeMarkup u ++ "</span>" _ -> putStrLn "FIXME" @@ -360,9 +391,9 @@ verticalHome :: GUI -> IO () verticalHome gui = do adjustment <- scrolledWindowGetVAdjustment (mScrollWindow gui)- min <- adjustmentGetLower adjustment+ lower <- adjustmentGetLower adjustment - adjustmentSetValue adjustment min+ adjustmentSetValue adjustment lower verticalEnd :: GUI -> IO () verticalEnd gui = do
+ examples/ui.xml view
@@ -0,0 +1,86 @@+<interface>+ <object class="GtkWindow" id="mainWindow">+ <child><object class="GtkVBox" id="windowBox">+ <property name="homogeneous">False</property>+ <property name="spacing">0</property>++ <!-- Scrolled window, will contain the webview -->+ <child>+ <object class="GtkScrolledWindow" id="webViewParent"></object>+ </child>+ ++ <!-- Prompt bar -->+ <child>+ <object class="GtkHBox" id="promptBox">+ <property name="homogeneous">False</property>+ <property name="spacing">10</property>+ + <child>+ <object class="GtkLabel" id="promptDescription"></object>+ <packing>+ <property name="fill">False</property>+ <property name="expand">False</property>+ </packing>+ </child>++ <child><object class="GtkEntry" id="promptEntry"></object></child>+ </object>++ <packing>+ <property name="fill">False</property>+ <property name="expand">False</property>+ </packing>+ </child>+++ <!-- Status bar -->+ <child>+ <object class="GtkHBox" id="statusBox">+ <property name="homogeneous">False</property>+ <property name="spacing">5</property>+ + <child>+ <object class="GtkLabel" id="progress"></object>+ <packing>+ <property name="fill">False</property>+ <property name="expand">False</property>+ </packing>+ </child>++ <child>+ <object class="GtkLabel" id="uri">+ <property name="ellipsize">PANGO_ELLIPSIZE_END</property>+ <property name="xalign">0</property>+ <property name="yalign">0</property>+ </object>+ </child>+ + <child>+ <object class="GtkLabel" id="scroll"></object>+ <packing>+ <property name="pack-type">GTK_PACK_END</property>+ <property name="fill">False</property>+ <property name="expand">False</property>+ </packing>+ </child>++ <child>+ <object class="GtkLabel" id="keys"></object>+ <packing>+ <property name="pack-type">GTK_PACK_END</property>+ <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>++ </object></child>+ </object>+</interface>
hbro.cabal view
@@ -1,8 +1,9 @@ Name: hbro-Version: 0.4.6+Version: 0.5.0 Synopsis: A suckless minimal KISSy browser -- Description: -- Homepage:+Category: Browser,Web Stability: alpha License: OtherLicense@@ -11,15 +12,9 @@ Author: koral Maintainer: koral at mailoo dot org -Category: Browser,Web---- Extra files to be distributed with the package, such as examples or--- a README.--- Extra-source-files: - Cabal-version: >=1.8 Build-type: Simple-+Data-files: examples/ui.xml Source-repository head Type: git@@ -28,18 +23,18 @@ Library Build-depends: base == 4.*,- webkit,+ bytestring,+ cmdargs,+ containers,+ dyre, glib, gtk,- glade, mtl,- containers,- dyre, process, url,- zeromq-haskell,- bytestring,- unix+ webkit,+ unix,+ zeromq-haskell Exposed-modules: Hbro.Core, Hbro.Gui,@@ -53,6 +48,7 @@ base == 4.*, glib, gtk,+ mtl, pango, process, unix,