diff --git a/Hbro/Core.hs b/Hbro/Core.hs --- a/Hbro/Core.hs +++ b/Hbro/Core.hs @@ -10,6 +10,7 @@ import Control.Concurrent import Control.Monad.Trans(liftIO) +import Data.ByteString.Char8 (pack) import qualified Data.Map as Map import qualified Data.Set as Set @@ -26,6 +27,7 @@ import System.Console.CmdArgs import System.Glib.Signals import System.Posix.Process +import qualified System.ZMQ as ZMQ -- }}} @@ -72,18 +74,11 @@ let browser = Browser options configuration gui let webView = mWebView gui - -- Load addtionnal settings from configuration + -- Load additionnal settings from configuration settings <- mWebSettings configuration webViewSetWebSettings webView settings (mSetup configuration) browser - -- Initialize IPC socket - pid <- getProcessID - let socketURI = "ipc://" ++ (mSocketDir configuration) ++ "/hbro." ++ show pid - putStrLn $ "Listening socket " ++ socketURI - - _ <- forkIO $ createRepSocket socketURI browser - -- Load homepage goHome browser @@ -120,7 +115,22 @@ widgetShowAll (mWindow gui) showPrompt False browser - mainGUI + + -- Initialize IPC socket + pid <- getProcessID + let socketURI = "ipc://" ++ (mSocketDir configuration) ++ "/hbro." ++ show pid + putStrLn $ "Listening socket " ++ socketURI + + ZMQ.withContext 1 $ \context -> do + _ <- forkIO $ createRepSocket context socketURI browser + + mainGUI + + ZMQ.withSocket context ZMQ.Req $ \reqSocket -> do + ZMQ.connect reqSocket socketURI + ZMQ.send reqSocket (pack "Quit") [] + reply <- ZMQ.receive reqSocket [] + return () -- }}} @@ -128,8 +138,8 @@ -- | Load homepage (retrieved from commandline options or configuration file) goHome :: Browser -> IO () goHome browser = case (mURI $ mOptions browser) of - Just uri -> loadURL uri browser - _ -> loadURL (mHomePage $ mConfiguration browser) browser + Just uri -> loadURI uri browser + _ -> loadURI (mHomePage $ mConfiguration browser) browser -- | Wrapper around webViewGoBack function goBack :: Browser -> IO () @@ -150,19 +160,19 @@ reload _ browser = webViewReloadBypassCache (mWebView $ mGUI browser) -- | Load given URL in the browser. -loadURL :: String -> Browser -> IO () -loadURL url browser = +loadURI :: String -> Browser -> IO () +loadURI url browser = case importURL url of - Just url' -> loadURL' url' browser + Just url' -> loadURI' url' browser _ -> return () --- | Backend function for loadURL. -loadURL' :: URL -> Browser -> IO () -loadURL' url@URL {url_type = Absolute _} browser = +-- | Backend function for loadURI. +loadURI' :: URL -> Browser -> IO () +loadURI' url@URL {url_type = Absolute _} browser = webViewLoadUri (mWebView $ mGUI browser) (exportURL url) -loadURL' url@URL {url_type = HostRelative} browser = +loadURI' url@URL {url_type = HostRelative} browser = webViewLoadUri (mWebView $ mGUI browser) ("file://" ++ exportURL url) >> putStrLn (show url) -loadURL' url@URL {url_type = _} browser = +loadURI' url@URL {url_type = _} browser = webViewLoadUri (mWebView $ mGUI browser) ("http://" ++ exportURL url) >> print url -- }}} diff --git a/Hbro/Extra/Bookmarks.hs b/Hbro/Extra/Bookmarks.hs --- a/Hbro/Extra/Bookmarks.hs +++ b/Hbro/Extra/Bookmarks.hs @@ -5,9 +5,6 @@ loadWithTag, deleteWithTag, add, - appendQueue, - popQueue, - popAndLoadQueue ) where -- {{{ Imports @@ -95,7 +92,7 @@ entry <- catch (hGetLine output) (\e -> return "ERROR" ) case reverse . words $ entry of ["ERROR"] -> return () - uri:_ -> loadURL uri browser + uri:_ -> loadURI uri browser _ -> return () @@ -178,40 +175,3 @@ -- | getUri :: T.Text -> T.Text getUri line = let uri:_ = T.words line in uri - - --- {{{ Queueing system --- | -appendQueue :: Browser -> IO () -appendQueue browser = do - uri <- webViewGetUri (mWebView $ mGUI browser) - configHome <- getEnv "XDG_CONFIG_HOME" - - case uri of - Just u -> appendFile (configHome ++ "/hbro/queue") (u ++ "\n") - _ -> return () - --- | -popQueue :: Browser -> IO String -popQueue browser = do - configHome <- getEnv "XDG_CONFIG_HOME" - file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\e -> return T.empty) - - if file == T.empty - then return "" - else do - let fileLines = T.lines file - let file' = T.unlines . tail . nub $ fileLines - - T.writeFile (configHome ++ "/hbro/queue.old") file - T.writeFile (configHome ++ "/hbro/queue") file' - - return $ T.unpack (head fileLines) - -popAndLoadQueue :: Browser -> IO () -popAndLoadQueue browser = do - uri <- popQueue browser - case uri of - "" -> return () - _ -> loadURL uri browser --- }}} diff --git a/Hbro/Extra/BookmarksQueue.hs b/Hbro/Extra/BookmarksQueue.hs new file mode 100644 --- /dev/null +++ b/Hbro/Extra/BookmarksQueue.hs @@ -0,0 +1,96 @@ +module Hbro.Extra.BookmarksQueue where + +-- {{{ Imports +import Hbro.Types + +import Data.List +import qualified Data.Text as T +import qualified Data.Text.IO as T + +import Graphics.UI.Gtk.WebKit.WebView + +import System.Environment +-- }}} + + +-- | Add current URI to the end of the queue. +append :: Browser -> IO () +append browser = do + uri <- webViewGetUri (mWebView $ mGUI browser) + configHome <- getEnv "XDG_CONFIG_HOME" + + case uri of + Just u -> appendFile (configHome ++ "/hbro/queue") (u ++ "\n") + _ -> return () + +-- | Add current URI to the beginning of the queue. +push :: Browser -> IO () +push browser = do + uri <- webViewGetUri (mWebView $ mGUI browser) + configHome <- getEnv "XDG_CONFIG_HOME" + file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\e -> return T.empty) + + case uri of + Just u -> + if (file == T.empty) + then return () + else do + let fileLines = T.lines file + let file' = T.unlines . nub $ (T.pack u):fileLines + + T.writeFile (configHome ++ "/hbro/queue") file' + + return () + _ -> return () + +-- | Return the first URI from the queue, while removing it. +popFront :: Browser -> IO String +popFront browser = do + configHome <- getEnv "XDG_CONFIG_HOME" + file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\e -> return T.empty) + + if file == T.empty + then return "" + else do + let fileLines = T.lines file + let file' = T.unlines . tail . nub $ fileLines + + T.writeFile (configHome ++ "/hbro/queue.old") file + T.writeFile (configHome ++ "/hbro/queue") file' + + return $ T.unpack (head fileLines) + +-- | Return the last URI from the queue, while removing it. +popBack :: Browser -> IO String +popBack browser = do + configHome <- getEnv "XDG_CONFIG_HOME" + file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\e -> return T.empty) + + if file == T.empty + then return "" + else do + let fileLines = T.lines file + let file' = T.unlines . reverse . tail . reverse. nub $ fileLines + + T.writeFile (configHome ++ "/hbro/queue.old") file + T.writeFile (configHome ++ "/hbro/queue") file' + + return $ T.unpack (head $ reverse fileLines) + +-- | Return a random URI from the queue, while removing it. +-- popRandom :: Browser -> IO String +-- popRandom browser = do +-- configHome <- getEnv "XDG_CONFIG_HOME" +-- file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\e -> return T.empty) + +-- if file == T.empty +-- then return "" +-- else do +-- let fileLines = T.lines file +-- let file' = T.unlines . reverse . tail . reverse. nub $ fileLines +-- +-- T.writeFile (configHome ++ "/hbro/queue.old") file +-- T.writeFile (configHome ++ "/hbro/queue") file' + +-- return $ T.unpack (head $ reverse fileLines) + diff --git a/Hbro/Extra/Clipboard.hs b/Hbro/Extra/Clipboard.hs --- a/Hbro/Extra/Clipboard.hs +++ b/Hbro/Extra/Clipboard.hs @@ -36,6 +36,6 @@ primaryClip <- widgetGetClipboard (mWindow $ mGUI browser) selectionPrimary _ <- clipboardRequestText primaryClip $ \x -> case x of - Just uri -> putStrLn ("Loading URI from clipboard: " ++ uri) >> loadURL uri browser + Just uri -> putStrLn ("Loading URI from clipboard: " ++ uri) >> loadURI uri browser _ -> putStrLn "Loading URI from clipboard: empty clipboard." return () diff --git a/Hbro/Extra/History.hs b/Hbro/Extra/History.hs --- a/Hbro/Extra/History.hs +++ b/Hbro/Extra/History.hs @@ -37,7 +37,7 @@ let uri:_ = words $ r in - loadURL uri browser + loadURI uri browser _ -> putStrLn e where diff --git a/Hbro/Extra/Prompt.hs b/Hbro/Extra/Prompt.hs --- a/Hbro/Extra/Prompt.hs +++ b/Hbro/Extra/Prompt.hs @@ -26,15 +26,15 @@ return () -- | Prompt for URI to open in current window. -promptURL :: Bool -> Browser -> IO() +promptURL :: Bool -> Browser -> IO () promptURL False browser = prompt "Open URL" "" False browser (\b -> do uri <- entryGetText (mPromptEntry $ mGUI b) - loadURL uri b) + loadURI uri b) promptURL _ browser = do uri <- webViewGetUri (mWebView $ mGUI browser) case uri of Just url -> prompt "Open URL" url False browser (\b -> do u <- entryGetText (mPromptEntry $ mGUI b) - loadURL u b) + loadURI u b) _ -> return () diff --git a/Hbro/Socket.hs b/Hbro/Socket.hs --- a/Hbro/Socket.hs +++ b/Hbro/Socket.hs @@ -3,8 +3,6 @@ -- {{{ Imports import Hbro.Types -import Control.Monad - import Data.ByteString.Char8 (pack, unpack) import qualified Data.Map as Map @@ -15,31 +13,30 @@ -- }}} -- | Create a response socket to listen for commands. --- Loops on listenToSocket forever. -createRepSocket :: String -> Browser -> IO a -createRepSocket socketURI browser = withContext 1 $ \context -> do +-- Loops on listenToSocket until "Quit" command is received. +createRepSocket :: Context -> String -> Browser -> IO () +createRepSocket context socketURI browser = withSocket context Rep $ \repSocket -> do - bind repSocket socketURI - setOption repSocket (Linger 0) + bind repSocket socketURI + listenToSocket repSocket commandsList browser + where + commandsList = Map.fromList (defaultCommandsList ++ (mCommands $ mConfiguration browser)) - _ <- quitAdd 0 $ do - close repSocket - return False - let commandsList = Map.fromList (defaultCommandsList ++ (mCommands $ mConfiguration 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 = words $ unpack message + case words (unpack message) of + [] -> send repSocket (pack "ERROR Unknown command") [] + ["Quit"] -> send repSocket (pack "OK") [] + command:arguments -> do + case Map.lookup command commands of + Just callback -> callback arguments repSocket browser + _ -> send repSocket (pack "ERROR Unknown command") [] - case Map.lookup command commands of - Just callback -> callback arguments repSocket browser - _ -> send repSocket (pack "ERROR Unknown command") [] + listenToSocket repSocket commands browser -- | List of default supported requests. defaultCommandsList :: CommandsList diff --git a/examples/hbro.hs b/examples/hbro.hs --- a/examples/hbro.hs +++ b/examples/hbro.hs @@ -4,6 +4,7 @@ import Hbro.Config import Hbro.Core import qualified Hbro.Extra.Bookmarks as Bookmarks +import qualified Hbro.Extra.BookmarksQueue as Queue import Hbro.Extra.Clipboard import Hbro.Extra.History import Hbro.Extra.Misc @@ -111,8 +112,10 @@ (([Alt], "d"), Bookmarks.deleteWithTag), (([Control], "l"), Bookmarks.load), (([Control, Shift], "L"), Bookmarks.loadWithTag), - (([Control], "q"), Bookmarks.appendQueue), - (([Alt], "q"), Bookmarks.popAndLoadQueue) + (([Control], "q"), Queue.append), + (([Alt], "q"), \b -> do + uri <- Queue.popFront b + loadURI uri b) ] historyKeys :: KeysList @@ -271,6 +274,6 @@ promptGoogle browser = prompt "Google search" "" False browser (\browser' -> do keyWords <- entryGetText (mPromptEntry $ mGUI browser') - loadURL ("https://www.google.com/search?q=" ++ keyWords) browser' + loadURI ("https://www.google.com/search?q=" ++ keyWords) browser' return ()) diff --git a/hbro.cabal b/hbro.cabal --- a/hbro.cabal +++ b/hbro.cabal @@ -1,5 +1,5 @@ Name: hbro -Version: 0.6.6 +Version: 0.6.7 Synopsis: A suckless minimal KISSy browser -- Description: Homepage: http://projects.haskell.org/hbro/ @@ -44,6 +44,7 @@ Hbro.Config, Hbro.Core, Hbro.Extra.Bookmarks, + Hbro.Extra.BookmarksQueue, Hbro.Extra.Clipboard, Hbro.Extra.History, Hbro.Extra.Misc,