hbro 0.2.1 → 0.3
raw patch · 5 files changed
+106/−41 lines, 5 filesdep +bytestringdep +unixdep +zeromq-haskell
Dependencies added: bytestring, unix, zeromq-haskell
Files
- hbro.cabal +23/−27
- src/Browser.hs +12/−5
- src/Main.hs +7/−8
- src/Socket.hs +63/−0
- src/Util.hs +1/−1
hbro.cabal view
@@ -1,51 +1,47 @@ Name: hbro---- The package version. See the Haskell package versioning policy--- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for--- standards guiding when and how versions should be incremented.-Version: 0.2.1+Version: 0.3 Synopsis: A suckless minimal KISSy browser-stability: alpha---- A longer description of the package.+Stability: alpha -- Description: +-- Homepage: License: OtherLicense License-file: LICENSE+-- Copyright: Author: koral Maintainer: koral at mailoo dot org --- A copyright notice.--- Copyright: --Category: Web-Build-type: Simple+Category: Browser,Web -- Extra files to be distributed with the package, such as examples or -- a README. -- Extra-source-files: Cabal-version: >=1.6+Build-type: Simple Source-repository head- type: git- location: git@twyk.tk/haskell-browser.git+ Type: git+ Location: git@twyk.tk/haskell-browser.git Executable hbro- -- .hs or .lhs file containing the Main module. Main-is: Main.hs- - -- Packages needed in order to build this package.- Build-depends: base == 4.*, webkit, gtk, glade, mtl, containers, dyre, process, url- - -- Modules not exported by this package.- Other-modules: Gui Browser Util- - -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.- -- Build-tools: -+ Build-depends:+ base == 4.*,+ webkit,+ gtk,+ glade,+ mtl,+ containers,+ dyre,+ process,+ url,+ zeromq-haskell,+ bytestring,+ unix+ Other-modules: Gui Browser Util Socket+ -- Build-tools: Hs-Source-Dirs: src- Ghc-options: -Wall -threaded
src/Browser.hs view
@@ -1,14 +1,16 @@+{-# 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 import Graphics.UI.Gtk.WebKit.WebView import Graphics.UI.Gtk.WebKit.WebFrame import Graphics.UI.Gtk.WebKit.WebInspector@@ -16,6 +18,7 @@ import Network.URL import Prelude hiding (lookup) import System.Environment+import System.Posix.Process -- }}} -- {{{ Type definitions@@ -56,6 +59,10 @@ 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@@ -106,7 +113,7 @@ _ <- on inspector detachWindow $ do getWebView <- webInspectorGetWebView inspector- case getWebView of+ _ <- case getWebView of Just webView -> do containerRemove (mWindowBox gui) webView containerAdd (mInspectorWindow gui) webView widgetShowAll (mInspectorWindow gui)@@ -152,8 +159,8 @@ loadURL :: String -> GUI -> IO () loadURL url gui = case importURL url of- Just url -> loadURL' url gui- _ -> return ()+ Just url' -> loadURL' url' gui+ _ -> return () -- | Backend function for loadURL. loadURL' :: URL -> GUI -> IO ()
src/Main.hs view
@@ -40,10 +40,9 @@ (([Control], "i"), showWebInspector), (([Control], "u"), toggleSourceMode), (([], "t"), toggleStatusBar),- (([Control], "p"), print),+ (([Control], "p"), printPage), (([], "<F11>"), fullscreen), (([], "<Escape>"), unfullscreen)- ], mWebSettings = (do@@ -108,8 +107,8 @@ Just url -> labelSetMarkup urlLabel url _ -> labelSetMarkup urlLabel "" - _ <- on webView progressChanged $ \progress ->- labelSetMarkup progressLabel $ "<span foreground=\"yellow\">" ++ show progress ++ "%</span>"+ _ <- on webView progressChanged $ \progress' ->+ labelSetMarkup progressLabel $ "<span foreground=\"yellow\">" ++ show progress' ++ "%</span>" _ <- on webView loadFinished $ \_ -> labelSetMarkup progressLabel "<span foreground=\"green\">100%</span>"@@ -124,8 +123,8 @@ _ <- on webView downloadRequested $ \download -> do getUrl <- downloadGetUri download _ <- case getUrl of- Just url -> forkOS $ do rawSystem "wget" [url]; return ()- _ -> forkOS $ do rawSystem "pwd" []; return ()+ Just url -> forkOS $ do _ <- rawSystem "wget" [url]; return ()+ _ -> forkOS $ do _ <- rawSystem "pwd" []; return () return True _ <- on webView mimeTypePolicyDecisionRequested $ \_ request mimetype policyDecision -> do@@ -193,8 +192,8 @@ loadURL u g) _ -> return () - print :: GUI -> IO ()- print gui = do+ printPage :: GUI -> IO ()+ printPage gui = do frame <- webViewGetMainFrame (mWebView gui) webFramePrint frame
+ src/Socket.hs view
@@ -0,0 +1,63 @@+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 view
@@ -2,7 +2,7 @@ import Graphics.UI.Gtk --- |Converts a keyVal to a String.+-- | 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.