hbro 0.4.1 → 0.4.2

raw patch · 4 files changed

+48/−11 lines, 4 files

Files

• Hbro/Core.hs +2/−1
• Hbro/Util.hs +12/−0
• examples/Main.hs +32/−9
• hbro.cabal +2/−1

@@ -28,6 +28,7 @@  data Configuration = Configuration {     mHomePage       :: String,                                  -- ^ Startup page +    mSocketDir      :: String,                                  -- ^ Path to socket directory (/tmp for example)     mKeyBindings    :: [(([Modifier], String), GUI -> IO ())],  -- ^ List of keybindings     mWebSettings    :: IO WebSettings,                          -- ^ Web settings     mCustomizations :: GUI -> IO (),                            -- ^ Custom callbacks@@ -61,7 +62,7 @@      -- Initialize IPC socket     pid <- getProcessID-    _ <- forkIO $ createReplySocket ("ipc:///tmp/hbro." ++ (show pid)) gui+    _ <- forkIO $ createReplySocket ("ipc://" ++ (mSocketDir configuration) ++ "/hbro." ++ (show pid)) gui      -- Load configuration     settings <- mWebSettings configuration

@@ -1,6 +1,7 @@ module Hbro.Util where  import Graphics.UI.Gtk+import System.Process  -- | Converts a keyVal to a String. -- For printable characters, the corresponding String is returned, except for the space character for which "<Space>" is returned.@@ -23,3 +24,14 @@         "Menu"      -> Nothing         "ISO_Level3_Shift" -> Nothing         x           -> Just ('<':x ++ ">")+++-- | Like run `runCommand`, but return IO ()+runCommand' :: String -> IO ()+runCommand' command = runCommand command >> return ()++-- | Run external command and won't kill when parent process exit.+-- nohup for ignore all hup signal. +-- `> /dev/null 2>&1` redirect all stdout (1) and stderr (2) to `/dev/null`+runExternalCommand :: String -> IO ()+runExternalCommand command = runCommand' $ "nohup " ++ command ++ " > /dev/null 2>&1"

@@ -3,12 +3,14 @@ -- {{{ Imports import Hbro.Core import Hbro.Gui+import Hbro.Util  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.WebNavigationAction import Graphics.UI.Gtk.WebKit.WebView import Graphics.UI.Gtk.WebKit.WebSettings import System.Cmd@@ -17,13 +19,14 @@ main :: IO () main = browser Configuration {     mError       = Nothing,+    mSocketDir   = "/tmp",     mHomePage    = "https://www.google.com",      mKeyBindings = [ --      ((Mod,          Key),       Callback)         -- Browsing-        (([],           "<"),       back),-        (([Shift],      ">"),       forward),+        (([],           "<"),       goBack),+        (([Shift],      ">"),       goForward),         (([],           "s"),       stop),         (([],           "<F5>"),    reload True),         (([Shift],      "<F5>"),    reload False),@@ -134,14 +137,35 @@                 return True              _ <- on webView mimeTypePolicyDecisionRequested $ \_ request mimetype policyDecision -> do-                putStrLn mimetype                 getUrl <- networkRequestGetUri request                 case getUrl of-                    Just url -> putStrLn url+                    Just url -> putStrLn $ mimetype ++ ": " ++ url                     _        -> putStrLn "ERROR"                  return False +            -- On navigating to a new URI+            -- Return True to forbid navigation, False to allow+            _ <- on webView navigationPolicyDecisionRequested $ \_ request action policyDecision -> do+                getUri      <- networkRequestGetUri request+                reason      <- webNavigationActionGetReason action+                mouseButton <- webNavigationActionGetButton action++                case getUri of+                    Just ('m':'a':'i':'l':'t':'o':':':address) -> do+                        putStrLn $ "Mailing to: " ++ address+                        return True+                    Just uri -> +                        case mouseButton of+                            1 -> return False -- Left button +                            2 -> (runExternalCommand $ "hbro " ++ uri) >> return True -- Middle button+                            3 -> return False -- Right button+                            _ -> return False -- No mouse button pressed+                    _        -> return False+++                +             _ <- on webView newWindowPolicyDecisionRequested $ \_ request action policyDecision -> do                 getUrl <- networkRequestGetUri request                 case getUrl of@@ -156,11 +180,11 @@  -- Definitions     where-        back :: GUI -> IO ()-        back gui = webViewGoBack (mWebView gui)+        goBack :: GUI -> IO ()+        goBack gui = webViewGoBack (mWebView gui) -        forward :: GUI -> IO ()-        forward gui = webViewGoForward (mWebView gui)+        goForward :: GUI -> IO ()+        goForward gui = webViewGoForward (mWebView gui)          stop :: GUI -> IO ()         stop gui = webViewStopLoading (mWebView gui)@@ -221,4 +245,3 @@          unfullscreen :: GUI -> IO ()         unfullscreen gui = windowUnfullscreen (mWindow gui)-

@@ -1,5 +1,5 @@ Name:                hbro-Version:             0.4.1+Version:             0.4.2 Synopsis:            A suckless minimal KISSy browser -- Description:          -- Homepage:@@ -55,4 +55,5 @@         webkit     Main-is: Main.hs     Hs-Source-Dirs: examples  +    Ghc-options: -Wall -threaded