hbro 0.6.1 → 0.6.2
raw patch · 5 files changed
+86/−46 lines, 5 filesdep +split
Dependencies added: split
Files
- Hbro/Config.hs +1/−0
- Hbro/Core.hs +1/−0
- Hbro/Socket.hs +75/−45
- Hbro/Types.hs +7/−0
- hbro.cabal +2/−1
Hbro/Config.hs view
@@ -32,5 +32,6 @@ mKeys = [], mWebSettings = webSettingsNew, mSetup = \_ -> return () :: IO (),+ mCommands = [], mError = Nothing }
Hbro/Core.hs view
@@ -73,6 +73,7 @@ -- Initialize IPC socket pid <- getProcessID let socketURI = "ipc://" ++ (mSocketDir configuration) ++ "/hbro." ++ show pid+ putStrLn $ "Listening socket " ++ socketURI _ <- forkIO $ createRepSocket socketURI browser
Hbro/Socket.hs view
@@ -4,12 +4,19 @@ import Hbro.Types import Control.Monad+ import Data.ByteString.Char8 (pack, unpack)+import Data.List.Split+import qualified Data.Map as Map+ import Graphics.UI.Gtk.General.General import Graphics.UI.Gtk.WebKit.WebView+ import System.ZMQ -- }}} +-- | Create a response socket to listen for commands.+-- Loops on listenToSocket forever. createRepSocket :: String -> Browser -> IO a createRepSocket socketURI browser = withContext 1 $ \context -> do withSocket context Rep $ \repSocket -> do@@ -19,57 +26,80 @@ _ <- quitAdd 0 $ do close repSocket return False++ let commandsList = Map.fromList (defaultCommandsList ++ (mCommands $ mConfiguration browser)) - forever $ listenToSocket repSocket browser+ forever $ listenToSocket repSocket commandsList browser +-- | Listen for incoming requests from response socket.+-- Parse received commands and feed the corresponding callback, if any.+listenToSocket :: Socket Rep -> CommandsMap -> Browser -> IO ()+listenToSocket repSocket commands browser = do+ message <- receive repSocket []+ let command:arguments = splitOn " " $ unpack message -listenToSocket :: Socket Rep -> Browser -> IO ()-listenToSocket repSocket browser = do- command <- receive repSocket []+ case Map.lookup command commands of+ Just callback -> callback arguments repSocket browser+ _ -> send repSocket (pack "ERROR Unknown command") [] - case unpack command of- -- Get information- "getUri" -> do- getUri <- postGUISync $ webViewGetUri (mWebView $ mGUI browser)- case getUri of- Just uri -> send repSocket (pack uri) []- _ -> send repSocket (pack "ERROR No URL opened") []- "getTitle" -> do- getTitle <- postGUISync $ webViewGetTitle (mWebView $ mGUI browser)- case getTitle of- Just title -> send repSocket (pack title) []- _ -> send repSocket (pack "ERROR No title") []- "getFaviconUri" -> do- getUri <- postGUISync $ webViewGetIconUri (mWebView $ mGUI browser)- case getUri of- Just uri -> send repSocket (pack uri) []- _ -> send repSocket (pack "ERROR No favicon uri") []- "getLoadProgress" -> do- progress <- postGUISync $ webViewGetProgress (mWebView $ mGUI browser)- send repSocket (pack (show progress)) []+-- | List of default supported requests.+defaultCommandsList :: CommandsList+defaultCommandsList = [+ -- Get information+ ("getUri", \arguments repSocket browser -> do+ getUri <- postGUISync $ webViewGetUri (mWebView $ mGUI browser)+ case getUri of+ Just uri -> send repSocket (pack uri) []+ _ -> send repSocket (pack "ERROR No URL opened") [] ), - -- Trigger actions- ('l':'o':'a':'d':'U':'r':'i':' ':uri) -> do+ ("getTitle", \arguments repSocket browser -> do+ getTitle <- postGUISync $ webViewGetTitle (mWebView $ mGUI browser)+ case getTitle of+ Just title -> send repSocket (pack title) []+ _ -> send repSocket (pack "ERROR No title") [] ),++ ("getFaviconUri", \arguments repSocket browser -> do+ getUri <- postGUISync $ webViewGetIconUri (mWebView $ mGUI browser)+ case getUri of+ Just uri -> send repSocket (pack uri) []+ _ -> send repSocket (pack "ERROR No favicon uri") [] ),++ ("getLoadProgress", \arguments repSocket browser -> do+ progress <- postGUISync $ webViewGetProgress (mWebView $ mGUI browser)+ send repSocket (pack (show progress)) [] ),+++ -- Trigger actions+ ("loadUri", \arguments repSocket browser -> case arguments of + uri:_ -> do postGUIAsync $ webViewLoadUri (mWebView $ mGUI browser) uri send repSocket (pack "OK") []- "stopLoading" -> do- postGUIAsync $ webViewStopLoading (mWebView $ mGUI browser) - send repSocket (pack "OK") []- "reload" -> do- postGUIAsync $ webViewReload (mWebView $ mGUI browser)- send repSocket (pack "OK") []- "goBack" -> do- postGUIAsync $ webViewGoBack (mWebView $ mGUI browser)- send repSocket (pack "OK") []- "goForward" -> do- postGUIAsync $ webViewGoForward (mWebView $ mGUI browser)- send repSocket (pack "OK") []- "zoomIn" -> do- postGUIAsync $ webViewZoomIn (mWebView $ mGUI browser)- send repSocket (pack "OK") []- "zoomOut" -> do- postGUIAsync $ webViewZoomOut (mWebView $ mGUI browser)- send repSocket (pack "OK") []+ _ -> send repSocket (pack "ERROR: argument needed.") [] ), - _ -> send repSocket (pack "ERROR Unknown command") []+ ("stopLoading", \arguments repSocket browser -> do+ postGUIAsync $ webViewStopLoading (mWebView $ mGUI browser) + send repSocket (pack "OK") [] ),++ ("reload", \arguments repSocket browser -> do+ postGUIAsync $ webViewReload (mWebView $ mGUI browser)+ send repSocket (pack "OK") [] ),++ ("goBack", \arguments repSocket browser -> do+ postGUIAsync $ webViewGoBack (mWebView $ mGUI browser)+ send repSocket (pack "OK") [] ),++ ("goForward", \arguments repSocket browser -> do+ postGUIAsync $ webViewGoForward (mWebView $ mGUI browser)+ send repSocket (pack "OK") [] ),++ ("zoomIn", \arguments repSocket browser -> do+ postGUIAsync $ webViewZoomIn (mWebView $ mGUI browser)+ send repSocket (pack "OK") [] ),++ ("zoomOut", \arguments repSocket browser -> do+ postGUIAsync $ webViewZoomOut (mWebView $ mGUI browser)+ send repSocket (pack "OK") [] )+ ]++
Hbro/Types.hs view
@@ -2,6 +2,8 @@ module Hbro.Types where -- {{{ Imports+import Data.Map+ import Graphics.UI.Gtk.Builder import Graphics.UI.Gtk.Display.Label import Graphics.UI.Gtk.Entry.Entry@@ -15,6 +17,7 @@ import Prelude import System.Console.CmdArgs+import System.ZMQ -- }}} data Browser = Browser {@@ -35,6 +38,7 @@ mKeys :: KeysList, -- ^ List of keybindings mWebSettings :: IO WebSettings, -- ^ Web settings provided by webkit (see Webkit::WebSettings documentation) mSetup :: Browser -> IO (), -- ^ Custom startup instructions+ mCommands :: CommandsList, -- ^ Custom commands to use with IPC sockets mError :: Maybe String -- ^ Error } @@ -57,3 +61,6 @@ -- Note 2 : for printable characters accessed via the shift modifier, -- you do have to include Shift in modifiers list type KeysList = [(([Modifier], String), (Browser -> IO ()))]++type CommandsList = [(String, ([String] -> Socket Rep -> Browser -> IO ()))]+type CommandsMap = Map String ([String] -> Socket Rep -> Browser -> IO ())
hbro.cabal view
@@ -1,5 +1,5 @@ Name: hbro-Version: 0.6.1+Version: 0.6.2 Synopsis: A suckless minimal KISSy browser -- Description: Homepage: http://projects.haskell.org/hbro/@@ -35,6 +35,7 @@ mtl, pango, process,+ split, url, webkit, unix,