hbro 0.4.5 → 0.4.6
raw patch · 6 files changed
+273/−106 lines, 6 files
Files
- Hbro/Core.hs +63/−20
- Hbro/Gui.hs +14/−10
- Hbro/Socket.hs +1/−2
- Hbro/Util.hs +13/−12
- examples/Main.hs +180/−61
- hbro.cabal +2/−1
Hbro/Core.hs view
@@ -15,9 +15,13 @@ import Graphics.UI.Gtk.Abstract.Box import Graphics.UI.Gtk.Abstract.Container+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.WebView import Graphics.UI.Gtk.WebKit.WebFrame import Graphics.UI.Gtk.WebKit.WebInspector@@ -34,6 +38,7 @@ -- {{{ Type definitions data Browser = Browser {+ mArgs :: [String], mGUI :: GUI } @@ -44,7 +49,7 @@ mSocketDir :: String, -- ^ Path to socket directory (/tmp for example) mKeyBindings :: KeyBindingsList, -- ^ List of keybindings mWebSettings :: IO WebSettings, -- ^ Web settings- mCustomizations :: GUI -> IO (), -- ^ Custom callbacks+ mAtStartUp :: GUI -> IO (), -- ^ Custom startup instructions mError :: Maybe String -- ^ Error } -- }}}@@ -66,19 +71,26 @@ -- Create browser and load homepage. initBrowser :: Configuration -> IO () initBrowser configuration = do- -- Initialize GUI+ case (mError configuration) of+ Just error -> putStrLn error+ _ -> return ()++ -- Initialize browser args <- initGUI gui <- loadGUI ""+ let browser = Browser args gui -- Initialize IPC socket pid <- getProcessID- _ <- forkIO $ createReplySocket ("ipc://" ++ (mSocketDir configuration) ++ "/hbro." ++ (show pid)) gui+ _ <- forkOS $ createReplySocket ("ipc://" ++ (mSocketDir configuration) ++ "/hbro." ++ show pid) gui -- Load configuration settings <- mWebSettings configuration webViewSetWebSettings (mWebView gui) settings- (mCustomizations configuration) gui + -- Launch custom startup+ (mAtStartUp configuration) gui+ -- Load url let url = case args of [arg] -> arg@@ -90,21 +102,22 @@ let keyBindings = importKeyBindings (mKeyBindings configuration) - newWindowWebView <- webViewNew+ -- On new window request+ --newWindowWebView <- webViewNew _ <- on (mWebView gui) createWebView $ \frame -> do- --newUri <- webFrameGetUri frame--- case newUri of--- Just uri -> webViewLoadUri (mWebView gui) uri--- --Just uri -> runExternalCommand $ "hbro " ++ uri--- Nothing -> return ()- --return (mWebView gui)- return newWindowWebView+ newUri <- webFrameGetUri frame+ case newUri of+ Just uri -> webViewLoadUri (mWebView gui) uri+ --Just uri -> runExternalCommand $ "hbro " ++ uri+ Nothing -> return ()+ return (mWebView gui)+-- return newWindowWebView - _ <- on newWindowWebView loadCommitted $ \frame -> do- getUri <- (webViewGetUri newWindowWebView)- case getUri of - Just uri -> runExternalCommand $ "hbro " ++ uri- _ -> return ()+-- _ <- on newWindowWebView loadCommitted $ \frame -> do+-- getUri <- (webViewGetUri newWindowWebView)+-- case getUri of +-- Just uri -> runExternalCommand $ "hbro \"" ++ uri ++ "\""+-- _ -> return () -- Web inspector@@ -145,9 +158,19 @@ return True -- Key bindings+-- imContext <- get (mWebView gui) webViewImContext -- _ <- on (mWebView gui) keyPressEvent $ do--- return True+-- value <- eventKeyVal+-- modifiers <- eventModifier +-- let keyString = keyToString value+-- +-- case keyString of+-- Just "<Escape>" -> do+-- liftIO $ imContextFocusIn imContext+-- return True+-- _ -> return False+ _ <- after (mWebView gui) keyPressEvent $ do value <- eventKeyVal modifiers <- eventModifier@@ -157,12 +180,30 @@ case keyString of Just string -> do case Map.lookup (Set.fromList modifiers, string) keyBindings of- Just callback -> liftIO $ callback gui+ Just callback -> do+ liftIO $ callback gui+ liftIO $ labelSetMarkup (mKeysLabel gui) $ "<span foreground=\"green\">" ++ show modifiers ++ string ++ "</span>" _ -> liftIO $ putStrLn string _ -> return () return False +-- imContextFilterKeypress imContext $ do+-- value <- eventKeyVal+-- modifiers <- eventModifier++-- let keyString = keyToString value+-- putStrLn keyString++-- -- case keyString of +-- -- Just string -> do +-- -- case Map.lookup (Set.fromList 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)@@ -186,6 +227,7 @@ Just url' -> loadURL' url' gui _ -> return () + -- | Backend function for loadURL. loadURL' :: URL -> GUI -> IO () loadURL' url@URL {url_type = Absolute _} gui =@@ -203,6 +245,7 @@ browser = Dyre.wrapMain Dyre.defaultParams { Dyre.projectName = "hbro", Dyre.showError = showError,- Dyre.realMain = realMain+ Dyre.realMain = realMain,+ Dyre.ghcOpts = ["-threaded"] } -- }}}
Hbro/Gui.hs view
@@ -6,6 +6,7 @@ import Graphics.UI.Gtk --import Graphics.UI.Gtk.Abstract.Misc+import Graphics.UI.Gtk.Glade import Graphics.UI.Gtk.WebKit.WebView -- }}} @@ -20,6 +21,7 @@ mStatusBox :: HBox, -- ^ Status bar's layout mProgressLabel :: Label, mUrlLabel :: Label,+ mKeysLabel :: Label, mScrollLabel :: Label } @@ -27,15 +29,15 @@ -- | 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+ -- 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"+-- -- 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@@ -53,7 +55,8 @@ promptLabel <- labelNew Nothing promptEntry <- entryNew progressLabel <- labelNew (Just "0%")- urlLabel <- labelNew (Just "")+ urlLabel <- labelNew Nothing+ keysLabel <- labelNew Nothing scrollLabel <- labelNew (Just "0%") boxPackStart winBox scrollWindow PackGrow 0@@ -64,6 +67,7 @@ boxPackStart statusBox progressLabel PackNatural 0 boxPackStart statusBox urlLabel PackGrow 0 boxPackEnd statusBox scrollLabel PackNatural 0+ boxPackEnd statusBox keysLabel PackNatural 0 containerAdd window winBox containerAdd scrollWindow webView @@ -81,7 +85,7 @@ mainQuit return True - return $ GUI window inspectorWindow scrollWindow webView promptLabel promptEntry winBox statusBox progressLabel urlLabel scrollLabel+ return $ GUI window inspectorWindow scrollWindow webView promptLabel promptEntry winBox statusBox progressLabel urlLabel keysLabel scrollLabel -- }}} -- {{{ Prompt
Hbro/Socket.hs view
@@ -16,7 +16,6 @@ forever $ do command <- receive socket [] case unpack command of- -- Get information "getUri" -> do getUri <- webViewGetUri (mWebView gui)@@ -60,5 +59,5 @@ webViewZoomOut (mWebView gui) send socket (pack "OK") [] - _ -> send socket (pack "ERROR Wrong command") []+ _ -> send socket (pack "ERROR Unknown command") []
Hbro/Util.hs view
@@ -20,18 +20,19 @@ 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 ++ ">")+ "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+ "dead_circumflex" -> Just "^"+ x -> Just ('<':x ++ ">") -- | Converts key bindings list to a map. -- | Calls importKeyBindings'.
examples/Main.hs view
@@ -24,48 +24,78 @@ import System.Glib.Attributes import System.Glib.Signals-import System.Process (runCommand)+import System.Process +import System.Posix.Process -- }}} main :: IO () main = browser Configuration {- mError = Nothing,- mSocketDir = "/tmp",- mHomePage = "https://www.google.com",+ -- Do not change this+ mError = Nothing, + -- Directory where 0MQ sockets will be created+ mSocketDir = socketDir,++ -- URI loaded at startup+ mHomePage = "https://www.google.com",+++ -- Custom keys+ -- 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 mKeyBindings = [--- ((Modifiers, Key), Callback)- -- Browsing- (([], "<"), goBack),- (([Shift], ">"), goForward),- (([], "s"), stop),- (([], "<F5>"), reload True),- (([Shift], "<F5>"), reload False),+-- ((Modifiers, Key), Callback)+ -- Browse+ (([], "<"), goBack),+ (([Shift], ">"), goForward),+ (([], "s"), stop),+ (([], "<F5>"), reload True),+ (([Shift], "<F5>"), reload False),+ (([], "^"), horizontalHome),+ (([], "$"), horizontalEnd),+ (([], "<Home>"), verticalHome),+ (([], "<End>"), verticalEnd), - -- Zooming- (([Shift], "+"), zoomIn),- (([], "-"), zoomOut),+ -- Zoom+ (([Shift], "+"), zoomIn),+ (([], "-"), zoomOut), -- Prompt- (([], "o"), promptURL False), - (([Shift], "O"), promptURL True),+ (([], "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),+ (([Shift], "/"), promptFind False True True),+ (([Shift], "?"), promptFind False False True),+ (([], "n"), findNext False True True),+ (([Shift], "N"), findNext False False True), + -- Copy/paste+ (([], "y"), copyUri),+ (([Control], "y"), copyTitle),+ --(([], "p"), pasteUri), -- /!\ UNSTABLE, can't see why...++ -- Bookmarks+ (([Control], "d"), addToBookmarks),+ (([Control], "l"), loadFromBookmarks),+ -- Others- (([Control], "i"), showWebInspector),- (([Control], "u"), toggleSourceMode),- (([], "t"), toggleStatusBar),- (([Control], "p"), printPage),- (([], "<F11>"), fullscreen),- (([], "<Escape>"), unfullscreen)+ (([Control], "i"), showWebInspector),+ (([Control], "u"), toggleSourceMode),+ (([], "t"), toggleStatusBar),+ (([Control], "p"), printPage),+ (([], "<F11>"), fullscreen),+ (([], "<Escape>"), unfullscreen) ], - mWebSettings = (do++ -- Various web settings+ -- Commented lines correspond to default values+ -- For more details, please refer to WebSettings documentation+ mWebSettings = do settings <- webSettingsNew set settings [ --SETTING DEFAULT VALUE @@ -107,12 +137,13 @@ --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 + --webSettingsZoomStep := 0.1 ]- return settings),+ return settings, + -- Custom callbacks- mCustomizations = \gui -> (let+ mAtStartUp = \gui -> (let webView = mWebView gui scrollWindow = mScrollWindow gui progressLabel = mProgressLabel gui@@ -120,28 +151,30 @@ scrollLabel = mScrollLabel gui window = mWindow gui in do+ -- Default background (for status bar) widgetModifyBg window StateNormal (Color 0 0 10000)- adjustment <- scrolledWindowGetVAdjustment scrollWindow - -- Scroll position- onValueChanged adjustment $ do+ -- Scroll position in status bar+ adjustment <- scrolledWindowGetVAdjustment scrollWindow+ _ <- onValueChanged adjustment $ do current <- adjustmentGetValue adjustment- min <- adjustmentGetLower adjustment- max <- adjustmentGetUpper adjustment+ lower <- adjustmentGetLower adjustment+ upper <- adjustmentGetUpper adjustment page <- adjustmentGetPageSize adjustment - case (max-min-page) of+ case upper-lower-page of 0 -> labelSetMarkup scrollLabel "ALL"- x -> labelSetMarkup scrollLabel $ (show (round $ current/x*100)) ++ "%"+ x -> labelSetMarkup scrollLabel $ show (round $ current/x*100) ++ "%" - _ <- on webView loadStarted $ \_ -> do + -- Page load+ _ <- on webView loadStarted $ \_ -> do labelSetMarkup progressLabel "<span foreground=\"red\">0%</span>" _ <- on webView loadCommitted $ \_ -> do getUri <- (webViewGetUri webView) case getUri of - Just uri -> labelSetMarkup urlLabel $ "<span weight=\"bold\" foreground=\"white\">" ++ (escapeMarkup uri) ++ "</span>"- _ -> labelSetMarkup urlLabel ""+ Just uri -> labelSetMarkup urlLabel $ "<span weight=\"bold\" foreground=\"white\">" ++ escapeMarkup uri ++ "</span>"+ _ -> labelSetMarkup urlLabel "<span weight=\"bold\" foreground=\"red\">ERROR</span>" _ <- on webView progressChanged $ \progress' -> labelSetMarkup progressLabel $ "<span foreground=\"yellow\">" ++ show progress' ++ "%</span>"@@ -152,29 +185,30 @@ getUri <- webViewGetUri webView getTitle <- webViewGetTitle webView case (getUri, getTitle) of- (Just uri, Just title) -> (runCommand $ scriptsDir ++ "/historyHandler.sh \"" ++ uri ++ "\" \"" ++ title ++ "\"") >> return ()+ (Just uri, Just title) -> historyHandler uri title _ -> return () - _ <- on webView loadError $ \_ _ _ -> do labelSetMarkup progressLabel "<span foreground=\"red\">ERROR</span>" return False - _ <- on webView titleChanged $ \_ title -> do- set window [ windowTitle := title]+ _ <- on webView titleChanged $ \_ title ->+ set window [ windowTitle := ("hbro | " ++ title)] + -- Special requests _ <- on webView downloadRequested $ \download -> do- getUrl <- downloadGetUri download- _ <- case getUrl of- Just url -> runExternalCommand $ "wget \"" ++ url ++ "\""- _ -> return ()+ getUri <- downloadGetUri download+ _ <- case getUri of+ Just uri -> downloadHandler uri + _ -> return () return True _ <- on webView mimeTypePolicyDecisionRequested $ \_ request mimetype policyDecision -> do- getUrl <- networkRequestGetUri request- case getUrl of- Just url -> putStrLn $ mimetype ++ ": " ++ url- _ -> putStrLn "ERROR"+ getUri <- networkRequestGetUri request+ case (getUri, mimetype) of+ --(Just uri, 'a':'p':'p':'l':'i':'c':'a':'t':'i':'o':'n':'/':_) -> downloadHandler uri+ (Just uri, _) -> putStrLn $ mimetype ++ ": " ++ uri+ _ -> putStrLn "FIXME" return False @@ -192,7 +226,7 @@ Just uri -> case mouseButton of 1 -> return False -- Left button - 2 -> (runExternalCommand $ "hbro " ++ uri) >> return True -- Middle button+ 2 -> runExternalCommand ("hbro \"" ++ uri ++ "\"") >> return True -- Middle button 3 -> return False -- Right button _ -> return False -- No mouse button pressed _ -> return False@@ -211,19 +245,28 @@ _ <- 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 urlLabel $ "<span foreground=\"#5555ff\">" ++ escapeMarkup u ++ "</span>"+ (_, Just u) -> labelSetMarkup urlLabel $ "<span foreground=\"white\" weight=\"bold\">" ++ escapeMarkup u ++ "</span>" _ -> putStrLn "FIXME" + + -- Favicon+ --_ <- on webView iconLoaded $ \uri -> do something+ return () )} -- Definitions where+ -- Constants scriptsDir :: String scriptsDir = "~/.config/hbro/scripts/" + socketDir :: String+ socketDir = "/tmp"++ -- Browse goBack :: GUI -> IO () goBack gui = webViewGoBack (mWebView gui) @@ -237,6 +280,7 @@ reload True gui = webViewReload (mWebView gui) reload _ gui = webViewReloadBypassCache (mWebView gui) + -- Zoom zoomIn :: GUI -> IO () zoomIn gui = webViewZoomIn (mWebView gui) @@ -266,17 +310,17 @@ loadURL u g) _ -> return () - promptFind :: Bool -> Bool -> GUI -> IO ()- promptFind caseSensitive forward gui =+ promptFind :: Bool -> Bool -> Bool -> GUI -> IO ()+ promptFind caseSensitive forward wrap gui = prompt "Search" "" True gui (\gui' -> do keyWord <- entryGetText (mPrompt gui')- webViewSearchText (mWebView gui) keyWord caseSensitive forward True+ found <- webViewSearchText (mWebView gui) keyWord caseSensitive forward wrap return ()) - findNext :: Bool -> Bool -> GUI -> IO()- findNext caseSensitive forward gui = do+ findNext :: Bool -> Bool -> Bool -> GUI -> IO()+ findNext caseSensitive forward wrap gui = do keyWord <- entryGetText (mPrompt gui)- webViewSearchText (mWebView gui) keyWord caseSensitive forward True+ found <- webViewSearchText (mWebView gui) keyWord caseSensitive forward wrap return () printPage :: GUI -> IO ()@@ -289,3 +333,78 @@ unfullscreen :: GUI -> IO () unfullscreen gui = windowUnfullscreen (mWindow gui)+++ -- Copy/paste+ copyUri :: GUI -> IO ()+ copyUri gui = do+ getUri <- webViewGetUri (mWebView gui)+ case getUri of+ Just u -> runCommand ("echo -n " ++ u ++ " | xclip") >> return ()+ _ -> return ()++ copyTitle :: GUI -> IO ()+ copyTitle gui = do+ getTitle <- webViewGetTitle (mWebView gui)+ case getTitle of+ Just t -> runCommand ("echo -n " ++ t ++ " | xclip") >> return ()+ _ -> return ()++ pasteUri :: GUI -> IO ()+ pasteUri gui = do+ uri <- readProcess "xclip" ["-o"] []+ loadURL uri gui+++ -- Scrolling+ verticalHome :: GUI -> IO ()+ verticalHome gui = do+ adjustment <- scrolledWindowGetVAdjustment (mScrollWindow gui)+ min <- adjustmentGetLower adjustment++ adjustmentSetValue adjustment min++ verticalEnd :: GUI -> IO ()+ verticalEnd gui = do+ adjustment <- scrolledWindowGetVAdjustment (mScrollWindow gui)+ upper <- adjustmentGetUpper adjustment++ adjustmentSetValue adjustment upper++ horizontalHome :: GUI -> IO ()+ horizontalHome gui = do+ adjustment <- scrolledWindowGetHAdjustment (mScrollWindow gui)+ lower <- adjustmentGetLower adjustment++ adjustmentSetValue adjustment lower++ horizontalEnd :: GUI -> IO ()+ horizontalEnd gui = do+ adjustment <- scrolledWindowGetHAdjustment (mScrollWindow gui)+ upper <- adjustmentGetUpper adjustment++ adjustmentSetValue adjustment upper ++ -- Handlers+ downloadHandler :: String -> IO ()+ downloadHandler uri = runExternalCommand $ "wget \"" ++ uri ++ "\""++ historyHandler :: String -> String -> IO ()+ historyHandler uri title = runCommand (scriptsDir ++ "/historyHandler.sh \"" ++ uri ++ "\" \"" ++ title ++ "\"") >> return ()+++ -- Bookmarks+ addToBookmarks :: GUI -> IO ()+ addToBookmarks gui = do+ getUri <- webViewGetUri (mWebView gui)+ case getUri of+ Just uri -> prompt "Bookmark with tag:" "" False gui (\g -> do + tags <- entryGetText (mPrompt g)+ runExternalCommand $ scriptsDir ++ "bookmarks.sh add " ++ uri ++ " " ++ tags)+ _ -> return ()++ loadFromBookmarks :: GUI -> IO ()+ loadFromBookmarks gui = do + pid <- getProcessID+ runExternalCommand $ scriptsDir ++ "bookmarks.sh load \"" ++ socketDir ++ "/hbro." ++ show pid ++ "\""+
hbro.cabal view
@@ -1,5 +1,5 @@ Name: hbro-Version: 0.4.5+Version: 0.4.6 Synopsis: A suckless minimal KISSy browser -- Description: -- Homepage:@@ -55,6 +55,7 @@ gtk, pango, process,+ unix, webkit Main-is: Main.hs Hs-Source-Dirs: examples