diff --git a/Hbro/Core.hs b/Hbro/Core.hs --- a/Hbro/Core.hs +++ b/Hbro/Core.hs @@ -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) $ "" ++ show modifiers ++ string ++ "" - _ -> 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, diff --git a/Hbro/Gui.hs b/Hbro/Gui.hs --- a/Hbro/Gui.hs +++ b/Hbro/Gui.hs @@ -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 diff --git a/Hbro/Socket.hs b/Hbro/Socket.hs --- a/Hbro/Socket.hs +++ b/Hbro/Socket.hs @@ -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") [] diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -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 @@ (([], ""), verticalHome), (([], ""), verticalEnd), - -- Zoom + -- Display (([Shift], "+"), zoomIn), (([], "-"), zoomOut), + (([], ""), fullscreen), + (([], ""), 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), - (([], ""), fullscreen), - (([], ""), 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 $ "" ++ show modifiers ++ string ++ "" + _ -> return () + + return False + -- Page load _ <- on webView loadStarted $ \_ -> do labelSetMarkup progressLabel "0%" @@ -173,8 +204,8 @@ _ <- on webView loadCommitted $ \_ -> do getUri <- (webViewGetUri webView) case getUri of - Just uri -> labelSetMarkup urlLabel $ "" ++ escapeMarkup uri ++ "" - _ -> labelSetMarkup urlLabel "ERROR" + Just uri -> labelSetMarkup uriLabel $ "" ++ escapeMarkup uri ++ "" + _ -> labelSetMarkup uriLabel "ERROR" _ <- on webView progressChanged $ \progress' -> labelSetMarkup progressLabel $ "" ++ show progress' ++ "%" @@ -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 $ "" ++ escapeMarkup u ++ "" - (_, Just u) -> labelSetMarkup urlLabel $ "" ++ escapeMarkup u ++ "" + (Just u, _) -> labelSetMarkup uriLabel $ "" ++ escapeMarkup u ++ "" + (_, Just u) -> labelSetMarkup uriLabel $ "" ++ escapeMarkup u ++ "" _ -> 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 diff --git a/examples/ui.xml b/examples/ui.xml new file mode 100644 --- /dev/null +++ b/examples/ui.xml @@ -0,0 +1,86 @@ + + + + False + 0 + + + + + + + + + + + False + 10 + + + + + False + False + + + + + + + + False + False + + + + + + + + False + 5 + + + + + False + False + + + + + + PANGO_ELLIPSIZE_END + 0 + 0 + + + + + + + GTK_PACK_END + False + False + + + + + + + GTK_PACK_END + False + False + + + + + + False + False + + + + + + diff --git a/hbro.cabal b/hbro.cabal --- a/hbro.cabal +++ b/hbro.cabal @@ -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,