hbro 0.4 → 0.4.1
raw patch · 11 files changed
+655/−643 lines, 11 filesdep +hbro
Dependencies added: hbro
Files
- Hbro/Core.hs +184/−0
- Hbro/Gui.hs +138/−0
- Hbro/Socket.hs +64/−0
- Hbro/Util.hs +25/−0
- examples/Main.hs +224/−0
- hbro.cabal +20/−9
- src/Browser.hs +0/−184
- src/Gui.hs +0/−138
- src/Main.hs +0/−224
- src/Socket.hs +0/−63
- src/Util.hs +0/−25
+ Hbro/Core.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE OverloadedStrings #-} +module Hbro.Core where++-- {{{ Imports+import Hbro.Gui+import Hbro.Socket+import Hbro.Util++import qualified Config.Dyre as Dyre+import Control.Concurrent+import Control.Monad.Trans(liftIO)+import Data.Map+import Graphics.UI.Gtk +import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.WebKit.WebFrame+import Graphics.UI.Gtk.WebKit.WebInspector+import Graphics.UI.Gtk.WebKit.WebSettings+import Network.URL+import Prelude hiding (lookup)+import System.Environment+import System.Posix.Process+-- }}}++-- {{{ Type definitions+data Browser = Browser {+ mGUI :: GUI+}++data Configuration = Configuration {+ mHomePage :: String, -- ^ Startup page + mKeyBindings :: [(([Modifier], String), GUI -> IO ())], -- ^ List of keybindings+ mWebSettings :: IO WebSettings, -- ^ Web settings+ mCustomizations :: GUI -> IO (), -- ^ Custom callbacks+ mError :: Maybe String -- ^ Error+}++instance Ord Modifier where+ m <= m' = fromEnum m <= fromEnum m'+-- }}}++-- {{{ Entry point+-- | Entry point of the application.+-- Check if help display is requested.+realMain :: Configuration -> IO ()+realMain configuration = do+ args <- getArgs++ case args of+ ["--help"] -> putStrLn "Usage: browser [url]"+ _ -> initBrowser configuration+-- }}}++-- {{{ Main function+-- | Application's main function.+-- Create browser and load homepage.+initBrowser :: Configuration -> IO ()+initBrowser configuration = do+ -- Initialize GUI+ args <- initGUI+ gui <- loadGUI ""++ -- Initialize IPC socket+ pid <- getProcessID+ _ <- forkIO $ createReplySocket ("ipc:///tmp/hbro." ++ (show pid)) gui++ -- Load configuration+ settings <- mWebSettings configuration+ webViewSetWebSettings (mWebView gui) settings+ (mCustomizations configuration) gui++ -- Load url+ let url = case args of+ [arg] -> arg+ _ -> mHomePage configuration++ webViewLoadUri (mWebView gui) url++ -- Load key bindings+ let keyBindings = fromList (mKeyBindings configuration)++ -- Open all link in current window.+ _ <- on (mWebView gui) createWebView $ \frame -> do+ newUri <- webFrameGetUri frame+ case newUri of+ Just uri -> webViewLoadUri (mWebView gui) uri+ Nothing -> return ()+ return (mWebView gui)++ -- Web inspector+ inspector <- webViewGetInspector (mWebView gui)+ _ <- on inspector inspectWebView $ \_ -> do+ webView <- webViewNew+ containerAdd (mInspectorWindow gui) webView+ return webView+ + _ <- on inspector showWindow $ do+ widgetShowAll (mInspectorWindow gui)+ return True++ -- 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 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++ -- Key bindings+ _ <- after (mWebView gui) keyPressEvent $ do+ keyVal <- eventKeyVal+ modifiers <- eventModifier++ let keyString = keyToString keyVal++ case keyString of + Just string -> do + case lookup (modifiers, string) keyBindings of+ Just callback -> liftIO $ callback gui+ _ -> liftIO $ putStrLn string + _ -> return ()++ return False++ -- Connect and show.+ _ <- onDestroy (mWindow gui) mainQuit+ widgetShowAll (mWindow gui)+ widgetHide (mPromptLabel gui)+ widgetHide (mPrompt gui)++ mainGUI+-- }}}++-- | Show web inspector for current webpage.+showWebInspector :: GUI -> IO ()+showWebInspector gui = do+ inspector <- webViewGetInspector (mWebView gui)+ webInspectorInspectCoordinates inspector 0 0+++-- | Load given URL in the browser.+loadURL :: String -> GUI -> IO ()+loadURL url gui =+ case importURL url of+ Just url' -> loadURL' url' gui+ _ -> return ()++-- | Backend function for loadURL.+loadURL' :: URL -> GUI -> IO ()+loadURL' url@URL {url_type = Absolute _} gui =+ webViewLoadUri (mWebView gui) (exportURL url)+loadURL' url@URL {url_type = HostRelative} gui = + webViewLoadUri (mWebView gui) ("file://" ++ exportURL url) >> putStrLn (show url)+loadURL' url@URL {url_type = _} gui = + webViewLoadUri (mWebView gui) ("http://" ++ exportURL url) >> print url++-- {{{ Dyre+showError :: Configuration -> String -> Configuration+showError configuration message = configuration { mError = Just message }++browser :: Configuration -> IO ()+browser = Dyre.wrapMain Dyre.defaultParams {+ Dyre.projectName = "hbro",+ Dyre.showError = showError,+ Dyre.realMain = realMain+}+-- }}}
+ Hbro/Gui.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE DoRec #-}+module Hbro.Gui where++-- {{{ Imports+import Control.Monad.Trans(liftIO)++import Graphics.UI.Gtk+import Graphics.UI.Gtk.WebKit.WebView+-- }}}++data GUI = GUI {+ mWindow :: Window, -- ^ Main window+ mInspectorWindow :: Window, -- ^ WebInspector window+ 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+}++-- {{{ Load glade GUI+-- | Load GUI from a glade file.+loadGUI :: String -> IO GUI+loadGUI gladePath = do+-- -- Note: crashes with a runtime error on console if fails!+-- Just xml <- xmlNew gladePath++-- -- 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"++ window <- windowNew+ inspectorWindow <- windowNew++ windowSetDefaultSize window 1024 768+ 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+ scrollWin <- scrolledWindowNew Nothing Nothing+ promptLabel <- labelNew Nothing+ promptEntry <- entryNew+ progressLabel <- labelNew (Just "0%")+ urlLabel <- labelNew (Just "")++ boxPackStart winBox scrollWin 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 PackNatural 0++ window `containerAdd` winBox+ scrollWin `containerAdd` webView++ set webView [ widgetCanDefault := True ]+ windowSetDefault window (Just webView)++ _ <- on webView closeWebView $ do+ mainQuit+ return True++ return $ GUI window inspectorWindow webView promptLabel promptEntry winBox statusBox progressLabel urlLabel+-- }}}++-- | Show or hide the prompt bar (label + entry).+showPrompt :: Bool -> GUI -> IO ()+showPrompt toShow gui = case toShow of+ False -> do widgetHide (mPromptLabel gui)+ widgetHide (mPrompt gui)+ _ -> do widgetShow (mPromptLabel gui)+ widgetShow (mPrompt gui)++-- | Show the prompt bar label and default text.+-- As the user validates its entry, the given callback is executed.+prompt :: String -> String -> Bool -> GUI -> (GUI -> IO ()) -> IO ()+prompt label defaultText incremental gui callback = do+ -- Show prompt+ showPrompt True gui++ -- Fill prompt+ labelSetText (mPromptLabel gui) label+ entrySetText (mPrompt gui) defaultText++ widgetGrabFocus (mPrompt gui)++ -- Register callback+ case incremental of+ True -> do + id1 <- on (mPrompt gui) editableChanged $ + liftIO $ callback gui+ rec id2 <- on (mPrompt gui) keyPressEvent $ do+ key <- eventKeyName+ + case key of+ "Return" -> do+ liftIO $ showPrompt False gui+ liftIO $ signalDisconnect id1+ liftIO $ signalDisconnect id2+ liftIO $ widgetGrabFocus (mWebView gui)+ "Escape" -> do+ liftIO $ showPrompt False gui+ liftIO $ signalDisconnect id1+ liftIO $ signalDisconnect id2+ liftIO $ widgetGrabFocus (mWebView gui)+ _ -> return ()+ return False+ return ()++ _ -> do+ rec id <- on (mPrompt gui) keyPressEvent $ do+ key <- eventKeyName++ case key of+ "Return" -> do+ liftIO $ showPrompt False gui+ liftIO $ callback gui+ liftIO $ signalDisconnect id+ liftIO $ widgetGrabFocus (mWebView gui)+ "Escape" -> do+ liftIO $ showPrompt False gui+ liftIO $ signalDisconnect id+ liftIO $ widgetGrabFocus (mWebView gui)+ _ -> return ()+ return False++ return ()+
+ Hbro/Socket.hs view
@@ -0,0 +1,64 @@+module Hbro.Socket where+ +-- {{{ Imports+import Hbro.Gui++import Control.Monad+import Data.ByteString.Char8 (pack, unpack)+import Graphics.UI.Gtk.WebKit.WebView+import System.ZMQ +-- }}}+ +createReplySocket :: String -> GUI -> IO a+createReplySocket socketName gui = withContext 1 $ \context -> do + withSocket context Rep $ \socket -> do+ bind socket socketName+ forever $ do+ command <- receive socket []+ case unpack command of++ -- Get information+ "getUri" -> do+ getUri <- 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)+ case getTitle of+ Just title -> send socket (pack title) []+ _ -> send socket (pack "ERROR No title") []+ "getFaviconUri" -> do+ getUri <- 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)+ send socket (pack (show progress)) []++ -- Trigger actions+ ('l':'o':'a':'d':'U':'r':'i':' ':uri) -> do+ webViewLoadUri (mWebView gui) uri+ send socket (pack "OK") []+ "stopLoading" -> do+ webViewStopLoading (mWebView gui) + send socket (pack "OK") []+ "reload" -> do+ webViewReload (mWebView gui)+ send socket (pack "OK") []+ "goBack" -> do+ webViewGoBack (mWebView gui)+ send socket (pack "OK") []+ "goForward" -> do+ webViewGoForward (mWebView gui)+ send socket (pack "OK") []+ "zoomIn" -> do+ webViewZoomIn (mWebView gui)+ send socket (pack "OK") []+ "zoomOut" -> do+ webViewZoomOut (mWebView gui)+ send socket (pack "OK") []++ _ -> send socket (pack "ERROR Wrong command") []+
+ Hbro/Util.hs view
@@ -0,0 +1,25 @@+module Hbro.Util where++import Graphics.UI.Gtk++-- | Converts a keyVal to a String.+-- For printable characters, the corresponding String is returned, except for the space character for which "<Space>" is returned.+-- For non-printable characters, the corresponding keyName between <> is returned.+-- For modifiers, Nothing is returned.+keyToString :: KeyVal -> Maybe String+keyToString keyVal = case keyToChar keyVal of+ Just ' ' -> Just "<Space>"+ Just char -> Just [char]+ _ -> case keyName keyVal of+ "Caps_Lock" -> Nothing+ "Shift_L" -> Nothing+ "Shift_R" -> Nothing+ "Control_L" -> Nothing+ "Control_R" -> Nothing+ "Alt_L" -> Nothing+ "Alt_R" -> Nothing+ "Super_L" -> Nothing+ "Super_R" -> Nothing+ "Menu" -> Nothing+ "ISO_Level3_Shift" -> Nothing+ x -> Just ('<':x ++ ">")
+ examples/Main.hs view
@@ -0,0 +1,224 @@+module Main where++-- {{{ Imports+import Hbro.Core+import Hbro.Gui++import Control.Concurrent+import Graphics.UI.Gtk+import Graphics.UI.Gtk.WebKit.Download+import Graphics.UI.Gtk.WebKit.NetworkRequest+import Graphics.UI.Gtk.WebKit.WebFrame+import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.WebKit.WebSettings+import System.Cmd+-- }}}++main :: IO ()+main = browser Configuration {+ mError = Nothing,+ mHomePage = "https://www.google.com",++ mKeyBindings = [+-- ((Mod, Key), Callback)+ -- Browsing+ (([], "<"), back),+ (([Shift], ">"), forward),+ (([], "s"), stop),+ (([], "<F5>"), reload True),+ (([Shift], "<F5>"), reload False),++ -- Zooming+ (([Shift], "+"), zoomIn),+ (([], "-"), zoomOut),++ -- Prompt+ (([], "o"), promptURL False), + (([Shift], "O"), promptURL True),++ -- Search+ (([Shift], "/"), promptFind False True),+ (([Shift], "?"), promptFind False False),+ (([], "n"), findNext False True),+ (([Shift], "N"), findNext False False),++ -- Others+ (([Control], "i"), showWebInspector),+ (([Control], "u"), toggleSourceMode),+ (([], "t"), toggleStatusBar),+ (([Control], "p"), printPage),+ (([], "<F11>"), fullscreen),+ (([], "<Escape>"), unfullscreen)+ ],++ mWebSettings = (do+ settings <- webSettingsNew+ set settings [+ --SETTING DEFAULT VALUE + --webSettingsCursiveFontFamily := "serif",+ --webSettingsDefaultFontFamily := "sans-serif",+ --webSettingsFantasyFontFamily := ,+ --webSettingsMonospaceFontFamily := "monospace",+ --webSettingsSansFontFamily := "sans-serif",+ --webSettingsSerifFontFamily := "serif",+ --webSettingsDefaultFontSize := ,+ --webSettingsDefaultMonospaceFontSize := 10,+ --webSettingsMinimumFontSize := 5,+ --webSettingsMinimumLogicalFontSize := 5,+ --webSettingsAutoLoadImages := True,+ --webSettingsAutoShrinkImages := True,+ --webSettingsDefaultEncoding := "iso-8859-1",+ --webSettingsEditingBehavior := EditingBehaviorWindows,+ --webSettingsEnableCaretBrowsing := ,+ webSettingsEnableDeveloperExtras := True,+ webSettingsEnableHtml5Database := False,+ webSettingsEnableHtml5LocalStorage := False,+ webSettingsEnableOfflineWebApplicationCache := True,+ webSettingsEnablePlugins := True,+ webSettingsEnablePrivateBrowsing := False,+ webSettingsEnableScripts := True,+ webSettingsEnableSpellChecking := True,+ webSettingsEnableUniversalAccessFromFileUris := True,+ webSettingsEnableXssAuditor := True,+ --webSettingsEnableSiteSpecificQuirks := False,+ --webSettingsEnableDomPaste := False,+ --webSettingsEnableDefaultContextMenu := True,+ webSettingsEnablePageCache := True,+ --webSettingsEnableSpatialNavigation := False,+ --webSettingsEnforce96Dpi := ,+ webSettingsJSCanOpenWindowAuto := True,+ --webSettingsPrintBackgrounds := True,+ --webSettingsResizableTextAreas := True,+ webSettingsSpellCheckingLang := Just "en_US",+ --webSettingsTabKeyCyclesThroughElements := True,+ webSettingsUserAgent := "Mozilla/5.0 (Windows; U; Windows NT 6.1; ru; rv:1.9.2.3) Gecko/20100401 Firefox/4.0 (.NET CLR 3.5.30729)"+ --webSettingsUserStylesheetUri := Nothing,+ --webSettingsZoomStep := 0.1 + ]+ return settings),++ -- Custom callbacks+ mCustomizations = \gui -> (let+ webView = mWebView gui+ progressLabel = mProgressLabel gui+ urlLabel = mUrlLabel gui+ window = mWindow gui+ in do+ _ <- on webView loadStarted $ \_ -> do + labelSetMarkup progressLabel "<span foreground=\"red\">0%</span>"++ _ <- on webView loadCommitted $ \_ -> do+ getUrl <- (webViewGetUri webView)+ case getUrl of + Just url -> labelSetMarkup urlLabel url + _ -> labelSetMarkup urlLabel ""++ _ <- on webView progressChanged $ \progress' ->+ labelSetMarkup progressLabel $ "<span foreground=\"yellow\">" ++ show progress' ++ "%</span>"++ _ <- on webView loadFinished $ \_ -> + labelSetMarkup progressLabel "<span foreground=\"green\">100%</span>"++ _ <- on webView loadError $ \_ _ _ -> do+ labelSetMarkup progressLabel "<span foreground=\"red\">ERROR</span>"+ return False++ _ <- on webView titleChanged $ \_ title -> do+ set window [ windowTitle := title]++ _ <- on webView downloadRequested $ \download -> do+ getUrl <- downloadGetUri download+ _ <- case getUrl of+ Just url -> forkOS $ (rawSystem "wget" [url]) >> return ()+ _ -> forkOS $ return ()+ return True++ _ <- on webView mimeTypePolicyDecisionRequested $ \_ request mimetype policyDecision -> do+ putStrLn mimetype+ getUrl <- networkRequestGetUri request+ case getUrl of+ Just url -> putStrLn url+ _ -> putStrLn "ERROR"++ return False++ _ <- on webView newWindowPolicyDecisionRequested $ \_ request action policyDecision -> do+ getUrl <- networkRequestGetUri request+ case getUrl of+ Just url -> putStrLn ("New Window: " ++ url)+ _ -> putStrLn "ERROR"++ return True++ return ()+ )}+++-- Definitions+ where+ back :: GUI -> IO ()+ back gui = webViewGoBack (mWebView gui)++ forward :: GUI -> IO ()+ forward gui = webViewGoForward (mWebView gui)++ stop :: GUI -> IO ()+ stop gui = webViewStopLoading (mWebView gui)++ reload :: Bool -> GUI -> IO ()+ reload True gui = webViewReload (mWebView gui)+ reload _ gui = webViewReloadBypassCache (mWebView gui)++ zoomIn :: GUI -> IO ()+ zoomIn gui = webViewZoomIn (mWebView gui)++ zoomOut :: GUI -> IO ()+ zoomOut gui = webViewZoomOut (mWebView gui)++ toggleSourceMode :: GUI -> IO ()+ toggleSourceMode gui = do+ currentMode <- webViewGetViewSourceMode (mWebView gui)+ webViewSetViewSourceMode (mWebView gui) (not currentMode)++ -- TODO+ toggleStatusBar :: GUI -> IO ()+ toggleStatusBar gui = return()+++ promptURL :: Bool -> GUI -> IO () + promptURL False gui = + prompt "Open URL" "" False gui (\g -> do + uri <- entryGetText (mPrompt g)+ loadURL uri g)+ promptURL _ gui = do+ uri <- webViewGetUri (mWebView gui)+ case uri of+ Just url -> prompt "Open URL" url False gui (\g -> do+ u <- entryGetText (mPrompt g)+ loadURL u g)+ _ -> return ()++ promptFind :: Bool -> Bool -> GUI -> IO ()+ promptFind caseSensitive forward gui =+ prompt "Search" "" True gui (\gui' -> do+ keyWord <- entryGetText (mPrompt gui')+ webViewSearchText (mWebView gui) keyWord caseSensitive forward True+ return ())++ findNext :: Bool -> Bool -> GUI -> IO()+ findNext caseSensitive forward gui = do+ keyWord <- entryGetText (mPrompt gui)+ webViewSearchText (mWebView gui) keyWord caseSensitive forward True+ return ()++ printPage :: GUI -> IO ()+ printPage gui = do+ frame <- webViewGetMainFrame (mWebView gui)+ webFramePrint frame++ fullscreen :: GUI -> IO ()+ fullscreen gui = windowFullscreen (mWindow gui)++ unfullscreen :: GUI -> IO ()+ unfullscreen gui = windowUnfullscreen (mWindow gui)+
hbro.cabal view
@@ -1,9 +1,9 @@ Name: hbro-Version: 0.4+Version: 0.4.1 Synopsis: A suckless minimal KISSy browser-Stability: alpha -- Description: -- Homepage:+Stability: alpha License: OtherLicense License-file: LICENSE@@ -17,7 +17,7 @@ -- a README. -- Extra-source-files: -Cabal-version: >=1.6+Cabal-version: >=1.8 Build-type: Simple @@ -25,8 +25,7 @@ Type: git Location: git@twyk.tk/haskell-browser.git -Executable hbro- Main-is: Main.hs+Library Build-depends: base == 4.*, webkit,@@ -40,8 +39,20 @@ zeromq-haskell, bytestring, unix- Other-modules: Gui Browser Util Socket- -- Build-tools: - Hs-Source-Dirs: src+ Exposed-modules:+ Hbro.Core,+ Hbro.Gui,+ Hbro.Socket+ Hbro.Util Ghc-options: -Wall -threaded - ++Executable hbro+ Build-depends: + hbro,+ base == 4.*,+ gtk,+ process,+ webkit+ Main-is: Main.hs+ Hs-Source-Dirs: examples +
− src/Browser.hs
@@ -1,184 +0,0 @@-{-# LANGUAGE OverloadedStrings #-} -module Browser where---- {{{ Imports-import Gui-import Socket-import Util--import qualified Config.Dyre as Dyre-import Control.Concurrent-import Control.Monad.Trans(liftIO)-import Data.Map-import Graphics.UI.Gtk -import Graphics.UI.Gtk.WebKit.WebView-import Graphics.UI.Gtk.WebKit.WebFrame-import Graphics.UI.Gtk.WebKit.WebInspector-import Graphics.UI.Gtk.WebKit.WebSettings-import Network.URL-import Prelude hiding (lookup)-import System.Environment-import System.Posix.Process--- }}}---- {{{ Type definitions-data Browser = Browser {- mGUI :: GUI-}--data Configuration = Configuration {- mHomePage :: String, -- ^ Startup page - mKeyBindings :: [(([Modifier], String), GUI -> IO ())], -- ^ List of keybindings- mWebSettings :: IO WebSettings, -- ^ Web settings- mCustomizations :: GUI -> IO (), -- ^ Custom callbacks- mError :: Maybe String -- ^ Error-}--instance Ord Modifier where- m <= m' = fromEnum m <= fromEnum m'--- }}}---- {{{ Entry point--- | Entry point of the application.--- Check if help display is requested.-realMain :: Configuration -> IO ()-realMain configuration = do- args <- getArgs-- case args of- ["--help"] -> putStrLn "Usage: browser [url]"- _ -> initBrowser configuration--- }}}---- {{{ Main function--- | Application's main function.--- Create browser and load homepage.-initBrowser :: Configuration -> IO ()-initBrowser configuration = do- -- Initialize GUI- args <- initGUI- gui <- loadGUI ""-- -- Initialize IPC socket- pid <- getProcessID- _ <- forkIO $ createReplySocket ("ipc:///tmp/hbro." ++ (show pid)) gui-- -- Load configuration- settings <- mWebSettings configuration- webViewSetWebSettings (mWebView gui) settings- (mCustomizations configuration) gui-- -- Load url- let url = case args of- [arg] -> arg- _ -> mHomePage configuration-- webViewLoadUri (mWebView gui) url-- -- Load key bindings- let keyBindings = fromList (mKeyBindings configuration)-- -- Open all link in current window.- _ <- on (mWebView gui) createWebView $ \frame -> do- newUri <- webFrameGetUri frame- case newUri of- Just uri -> webViewLoadUri (mWebView gui) uri- Nothing -> return ()- return (mWebView gui)-- -- Web inspector- inspector <- webViewGetInspector (mWebView gui)- _ <- on inspector inspectWebView $ \_ -> do- webView <- webViewNew- containerAdd (mInspectorWindow gui) webView- return webView- - _ <- on inspector showWindow $ do- widgetShowAll (mInspectorWindow gui)- return True-- -- 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 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-- -- Key bindings- _ <- after (mWebView gui) keyPressEvent $ do- keyVal <- eventKeyVal- modifiers <- eventModifier-- let keyString = keyToString keyVal-- case keyString of - Just string -> do - case lookup (modifiers, string) keyBindings of- Just callback -> liftIO $ callback gui- _ -> liftIO $ putStrLn string - _ -> return ()-- return False-- -- Connect and show.- _ <- onDestroy (mWindow gui) mainQuit- widgetShowAll (mWindow gui)- widgetHide (mPromptLabel gui)- widgetHide (mPrompt gui)-- mainGUI--- }}}---- | Show web inspector for current webpage.-showWebInspector :: GUI -> IO ()-showWebInspector gui = do- inspector <- webViewGetInspector (mWebView gui)- webInspectorInspectCoordinates inspector 0 0----- | Load given URL in the browser.-loadURL :: String -> GUI -> IO ()-loadURL url gui =- case importURL url of- Just url' -> loadURL' url' gui- _ -> return ()---- | Backend function for loadURL.-loadURL' :: URL -> GUI -> IO ()-loadURL' url@URL {url_type = Absolute _} gui =- webViewLoadUri (mWebView gui) (exportURL url)-loadURL' url@URL {url_type = HostRelative} gui = - webViewLoadUri (mWebView gui) ("file://" ++ exportURL url) >> putStrLn (show url)-loadURL' url@URL {url_type = _} gui = - webViewLoadUri (mWebView gui) ("http://" ++ exportURL url) >> print url---- {{{ Dyre-showError :: Configuration -> String -> Configuration-showError configuration message = configuration { mError = Just message }--browser :: Configuration -> IO ()-browser = Dyre.wrapMain Dyre.defaultParams {- Dyre.projectName = "hbro",- Dyre.showError = showError,- Dyre.realMain = realMain-}--- }}}
− src/Gui.hs
@@ -1,138 +0,0 @@-{-# LANGUAGE DoRec #-}-module Gui where---- {{{ Imports-import Control.Monad.Trans(liftIO)--import Graphics.UI.Gtk-import Graphics.UI.Gtk.WebKit.WebView--- }}}--data GUI = GUI {- mWindow :: Window, -- ^ Main window- mInspectorWindow :: Window, -- ^ WebInspector window- 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-}---- {{{ Load glade GUI--- | Load GUI from a glade file.-loadGUI :: String -> IO GUI-loadGUI gladePath = do--- -- Note: crashes with a runtime error on console if fails!--- Just xml <- xmlNew gladePath---- -- 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"-- window <- windowNew- inspectorWindow <- windowNew-- windowSetDefaultSize window 1024 768- 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- scrollWin <- scrolledWindowNew Nothing Nothing- promptLabel <- labelNew Nothing- promptEntry <- entryNew- progressLabel <- labelNew (Just "0%")- urlLabel <- labelNew (Just "")-- boxPackStart winBox scrollWin 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 PackNatural 0-- window `containerAdd` winBox- scrollWin `containerAdd` webView-- set webView [ widgetCanDefault := True ]- windowSetDefault window (Just webView)-- _ <- on webView closeWebView $ do- mainQuit- return True-- return $ GUI window inspectorWindow webView promptLabel promptEntry winBox statusBox progressLabel urlLabel--- }}}---- | Show or hide the prompt bar (label + entry).-showPrompt :: Bool -> GUI -> IO ()-showPrompt toShow gui = case toShow of- False -> do widgetHide (mPromptLabel gui)- widgetHide (mPrompt gui)- _ -> do widgetShow (mPromptLabel gui)- widgetShow (mPrompt gui)---- | Show the prompt bar label and default text.--- As the user validates its entry, the given callback is executed.-prompt :: String -> String -> Bool -> GUI -> (GUI -> IO ()) -> IO ()-prompt label defaultText incremental gui callback = do- -- Show prompt- showPrompt True gui-- -- Fill prompt- labelSetText (mPromptLabel gui) label- entrySetText (mPrompt gui) defaultText-- widgetGrabFocus (mPrompt gui)-- -- Register callback- case incremental of- True -> do - id1 <- on (mPrompt gui) editableChanged $ - liftIO $ callback gui- rec id2 <- on (mPrompt gui) keyPressEvent $ do- key <- eventKeyName- - case key of- "Return" -> do- liftIO $ showPrompt False gui- liftIO $ signalDisconnect id1- liftIO $ signalDisconnect id2- liftIO $ widgetGrabFocus (mWebView gui)- "Escape" -> do- liftIO $ showPrompt False gui- liftIO $ signalDisconnect id1- liftIO $ signalDisconnect id2- liftIO $ widgetGrabFocus (mWebView gui)- _ -> return ()- return False- return ()-- _ -> do- rec id <- on (mPrompt gui) keyPressEvent $ do- key <- eventKeyName-- case key of- "Return" -> do- liftIO $ showPrompt False gui- liftIO $ callback gui- liftIO $ signalDisconnect id- liftIO $ widgetGrabFocus (mWebView gui)- "Escape" -> do- liftIO $ showPrompt False gui- liftIO $ signalDisconnect id- liftIO $ widgetGrabFocus (mWebView gui)- _ -> return ()- return False-- return ()-
− src/Main.hs
@@ -1,224 +0,0 @@-module Main where---- {{{ Imports-import Browser-import Gui--import Control.Concurrent-import Graphics.UI.Gtk-import Graphics.UI.Gtk.WebKit.Download-import Graphics.UI.Gtk.WebKit.NetworkRequest-import Graphics.UI.Gtk.WebKit.WebFrame-import Graphics.UI.Gtk.WebKit.WebView-import Graphics.UI.Gtk.WebKit.WebSettings-import System.Cmd--- }}}--main :: IO ()-main = browser Configuration {- mError = Nothing,- mHomePage = "https://www.google.com",-- mKeyBindings = [--- ((Mod, Key), Callback)- -- Browsing- (([], "<"), back),- (([Shift], ">"), forward),- (([], "s"), stop),- (([], "<F5>"), reload True),- (([Shift], "<F5>"), reload False),-- -- Zooming- (([Shift], "+"), zoomIn),- (([], "-"), zoomOut),-- -- Prompt- (([], "o"), promptURL False), - (([Shift], "O"), promptURL True),-- -- Search- (([Shift], "/"), promptFind False True),- (([Shift], "?"), promptFind False False),- (([], "n"), findNext False True),- (([Shift], "N"), findNext False False),-- -- Others- (([Control], "i"), showWebInspector),- (([Control], "u"), toggleSourceMode),- (([], "t"), toggleStatusBar),- (([Control], "p"), printPage),- (([], "<F11>"), fullscreen),- (([], "<Escape>"), unfullscreen)- ],-- mWebSettings = (do- settings <- webSettingsNew- set settings [- --SETTING DEFAULT VALUE - --webSettingsCursiveFontFamily := "serif",- --webSettingsDefaultFontFamily := "sans-serif",- --webSettingsFantasyFontFamily := ,- --webSettingsMonospaceFontFamily := "monospace",- --webSettingsSansFontFamily := "sans-serif",- --webSettingsSerifFontFamily := "serif",- --webSettingsDefaultFontSize := ,- --webSettingsDefaultMonospaceFontSize := 10,- --webSettingsMinimumFontSize := 5,- --webSettingsMinimumLogicalFontSize := 5,- --webSettingsAutoLoadImages := True,- --webSettingsAutoShrinkImages := True,- --webSettingsDefaultEncoding := "iso-8859-1",- --webSettingsEditingBehavior := EditingBehaviorWindows,- --webSettingsEnableCaretBrowsing := ,- webSettingsEnableDeveloperExtras := True,- webSettingsEnableHtml5Database := False,- webSettingsEnableHtml5LocalStorage := False,- webSettingsEnableOfflineWebApplicationCache := True,- webSettingsEnablePlugins := True,- webSettingsEnablePrivateBrowsing := False,- webSettingsEnableScripts := True,- webSettingsEnableSpellChecking := True,- webSettingsEnableUniversalAccessFromFileUris := True,- webSettingsEnableXssAuditor := True,- --webSettingsEnableSiteSpecificQuirks := False,- --webSettingsEnableDomPaste := False,- --webSettingsEnableDefaultContextMenu := True,- webSettingsEnablePageCache := True,- --webSettingsEnableSpatialNavigation := False,- --webSettingsEnforce96Dpi := ,- webSettingsJSCanOpenWindowAuto := True,- --webSettingsPrintBackgrounds := True,- --webSettingsResizableTextAreas := True,- webSettingsSpellCheckingLang := Just "en_US",- --webSettingsTabKeyCyclesThroughElements := True,- webSettingsUserAgent := "Mozilla/5.0 (Windows; U; Windows NT 6.1; ru; rv:1.9.2.3) Gecko/20100401 Firefox/4.0 (.NET CLR 3.5.30729)"- --webSettingsUserStylesheetUri := Nothing,- --webSettingsZoomStep := 0.1 - ]- return settings),-- -- Custom callbacks- mCustomizations = \gui -> (let- webView = mWebView gui- progressLabel = mProgressLabel gui- urlLabel = mUrlLabel gui- window = mWindow gui- in do- _ <- on webView loadStarted $ \_ -> do - labelSetMarkup progressLabel "<span foreground=\"red\">0%</span>"-- _ <- on webView loadCommitted $ \_ -> do- getUrl <- (webViewGetUri webView)- case getUrl of - Just url -> labelSetMarkup urlLabel url - _ -> labelSetMarkup urlLabel ""-- _ <- on webView progressChanged $ \progress' ->- labelSetMarkup progressLabel $ "<span foreground=\"yellow\">" ++ show progress' ++ "%</span>"-- _ <- on webView loadFinished $ \_ -> - labelSetMarkup progressLabel "<span foreground=\"green\">100%</span>"-- _ <- on webView loadError $ \_ _ _ -> do- labelSetMarkup progressLabel "<span foreground=\"red\">ERROR</span>"- return False-- _ <- on webView titleChanged $ \_ title -> do- set window [ windowTitle := title]-- _ <- on webView downloadRequested $ \download -> do- getUrl <- downloadGetUri download- _ <- case getUrl of- Just url -> forkOS $ (rawSystem "wget" [url]) >> return ()- _ -> forkOS $ return ()- return True-- _ <- on webView mimeTypePolicyDecisionRequested $ \_ request mimetype policyDecision -> do- putStrLn mimetype- getUrl <- networkRequestGetUri request- case getUrl of- Just url -> putStrLn url- _ -> putStrLn "ERROR"-- return False-- _ <- on webView newWindowPolicyDecisionRequested $ \_ request action policyDecision -> do- getUrl <- networkRequestGetUri request- case getUrl of- Just url -> putStrLn ("New Window: " ++ url)- _ -> putStrLn "ERROR"-- return True-- return ()- )}----- Definitions- where- back :: GUI -> IO ()- back gui = webViewGoBack (mWebView gui)-- forward :: GUI -> IO ()- forward gui = webViewGoForward (mWebView gui)-- stop :: GUI -> IO ()- stop gui = webViewStopLoading (mWebView gui)-- reload :: Bool -> GUI -> IO ()- reload True gui = webViewReload (mWebView gui)- reload _ gui = webViewReloadBypassCache (mWebView gui)-- zoomIn :: GUI -> IO ()- zoomIn gui = webViewZoomIn (mWebView gui)-- zoomOut :: GUI -> IO ()- zoomOut gui = webViewZoomOut (mWebView gui)-- toggleSourceMode :: GUI -> IO ()- toggleSourceMode gui = do- currentMode <- webViewGetViewSourceMode (mWebView gui)- webViewSetViewSourceMode (mWebView gui) (not currentMode)-- -- TODO- toggleStatusBar :: GUI -> IO ()- toggleStatusBar gui = return()--- promptURL :: Bool -> GUI -> IO () - promptURL False gui = - prompt "Open URL" "" False gui (\g -> do - uri <- entryGetText (mPrompt g)- loadURL uri g)- promptURL _ gui = do- uri <- webViewGetUri (mWebView gui)- case uri of- Just url -> prompt "Open URL" url False gui (\g -> do- u <- entryGetText (mPrompt g)- loadURL u g)- _ -> return ()-- promptFind :: Bool -> Bool -> GUI -> IO ()- promptFind caseSensitive forward gui =- prompt "Search" "" True gui (\gui' -> do- keyWord <- entryGetText (mPrompt gui')- webViewSearchText (mWebView gui) keyWord caseSensitive forward True- return ())-- findNext :: Bool -> Bool -> GUI -> IO()- findNext caseSensitive forward gui = do- keyWord <- entryGetText (mPrompt gui)- webViewSearchText (mWebView gui) keyWord caseSensitive forward True- return ()-- printPage :: GUI -> IO ()- printPage gui = do- frame <- webViewGetMainFrame (mWebView gui)- webFramePrint frame-- fullscreen :: GUI -> IO ()- fullscreen gui = windowFullscreen (mWindow gui)-- unfullscreen :: GUI -> IO ()- unfullscreen gui = windowUnfullscreen (mWindow gui)-
− src/Socket.hs
@@ -1,63 +0,0 @@-module Socket where- -import Gui--import Control.Monad-import Data.ByteString.Char8 (pack, unpack)-import Graphics.UI.Gtk.WebKit.WebView-import System.ZMQ - - -createReplySocket :: String -> GUI -> IO a-createReplySocket socketName gui = withContext 1 $ \context -> do - withSocket context Rep $ \socket -> do- bind socket socketName- forever $ do- command <- receive socket []- case unpack command of-- -- Get information- "getUri" -> do- getUri <- 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)- case getTitle of- Just title -> send socket (pack title) []- _ -> send socket (pack "ERROR No title") []- "getFaviconUri" -> do- getUri <- 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)- send socket (pack (show progress)) []-- -- Trigger actions- ('l':'o':'a':'d':'U':'r':'i':' ':uri) -> do- webViewLoadUri (mWebView gui) uri- send socket (pack "OK") []- "stopLoading" -> do- webViewStopLoading (mWebView gui) - send socket (pack "OK") []- "reload" -> do- webViewReload (mWebView gui)- send socket (pack "OK") []- "goBack" -> do- webViewGoBack (mWebView gui)- send socket (pack "OK") []- "goForward" -> do- webViewGoForward (mWebView gui)- send socket (pack "OK") []- "zoomIn" -> do- webViewZoomIn (mWebView gui)- send socket (pack "OK") []- "zoomOut" -> do- webViewZoomOut (mWebView gui)- send socket (pack "OK") []-- _ -> send socket (pack "ERROR Wrong command") []-
− src/Util.hs
@@ -1,25 +0,0 @@-module Util where--import Graphics.UI.Gtk---- | Converts a keyVal to a String.--- For printable characters, the corresponding String is returned, except for the space character for which "<Space>" is returned.--- For non-printable characters, the corresponding keyName between <> is returned.--- For modifiers, Nothing is returned.-keyToString :: KeyVal -> Maybe String-keyToString keyVal = case keyToChar keyVal of- Just ' ' -> Just "<Space>"- Just char -> Just [char]- _ -> case keyName keyVal of- "Caps_Lock" -> Nothing- "Shift_L" -> Nothing- "Shift_R" -> Nothing- "Control_L" -> Nothing- "Control_R" -> Nothing- "Alt_L" -> Nothing- "Alt_R" -> Nothing- "Super_L" -> Nothing- "Super_R" -> Nothing- "Menu" -> Nothing- "ISO_Level3_Shift" -> Nothing- x -> Just ('<':x ++ ">")