diff --git a/Hbro/Core.hs b/Hbro/Core.hs --- a/Hbro/Core.hs +++ b/Hbro/Core.hs @@ -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 "" -> 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) $ "" ++ show modifiers ++ string ++ "" _ -> 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"] } -- }}} diff --git a/Hbro/Gui.hs b/Hbro/Gui.hs --- a/Hbro/Gui.hs +++ b/Hbro/Gui.hs @@ -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 diff --git a/Hbro/Socket.hs b/Hbro/Socket.hs --- a/Hbro/Socket.hs +++ b/Hbro/Socket.hs @@ -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") [] diff --git a/Hbro/Util.hs b/Hbro/Util.hs --- a/Hbro/Util.hs +++ b/Hbro/Util.hs @@ -20,18 +20,19 @@ Just ' ' -> Just "" 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'. diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -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), - (([], ""), reload True), - (([Shift], ""), reload False), +-- ((Modifiers, Key), Callback) + -- Browse + (([], "<"), goBack), + (([Shift], ">"), goForward), + (([], "s"), stop), + (([], ""), reload True), + (([Shift], ""), reload False), + (([], "^"), horizontalHome), + (([], "$"), horizontalEnd), + (([], ""), verticalHome), + (([], ""), 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), - (([], ""), fullscreen), - (([], ""), unfullscreen) + (([Control], "i"), showWebInspector), + (([Control], "u"), toggleSourceMode), + (([], "t"), toggleStatusBar), + (([Control], "p"), printPage), + (([], ""), fullscreen), + (([], ""), 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 "0%" _ <- on webView loadCommitted $ \_ -> do getUri <- (webViewGetUri webView) case getUri of - Just uri -> labelSetMarkup urlLabel $ "" ++ (escapeMarkup uri) ++ "" - _ -> labelSetMarkup urlLabel "" + Just uri -> labelSetMarkup urlLabel $ "" ++ escapeMarkup uri ++ "" + _ -> labelSetMarkup urlLabel "ERROR" _ <- on webView progressChanged $ \progress' -> labelSetMarkup progressLabel $ "" ++ show progress' ++ "%" @@ -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 "ERROR" 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 $ "" ++ (escapeMarkup u) ++ "" - (_, Just u) -> labelSetMarkup urlLabel $ "" ++ (escapeMarkup u) ++ "" + (Just u, _) -> labelSetMarkup urlLabel $ "" ++ escapeMarkup u ++ "" + (_, Just u) -> labelSetMarkup urlLabel $ "" ++ escapeMarkup u ++ "" _ -> 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 ++ "\"" + diff --git a/hbro.cabal b/hbro.cabal --- a/hbro.cabal +++ b/hbro.cabal @@ -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