packages feed

hbro 0.6.8.2 → 0.7.0.0

raw patch · 16 files changed

+809/−961 lines, 16 files

Files

Hbro/Core.hs view
@@ -1,5 +1,20 @@-{-# LANGUAGE OverloadedStrings #-} -module Hbro.Core where+{-# LANGUAGE OverloadedStrings #-}+module Hbro.Core (+-- * Main+    defaultConfig,+    launchHbro,+-- * Browsing+    goHome,+    loadURI,+-- * Scrolling    +    goTop,+    goBottom,+    goLeft,+    goRight,+-- * Misc+    printPage,+    executeJSFile+) where  -- {{{ Imports import Hbro.Gui@@ -11,20 +26,18 @@ import Config.Dyre.Paths  import Control.Concurrent-import Control.Monad.Trans(liftIO)+import Control.Monad.Reader -import Data.ByteString.Char8 (pack) import qualified Data.Map as Map import qualified Data.Set as Set  import Graphics.UI.Gtk.Abstract.Widget-import Graphics.UI.Gtk.General.General+import Graphics.UI.Gtk.General.General hiding(initGUI) import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.Misc.Adjustment import Graphics.UI.Gtk.Scrolling.ScrolledWindow import Graphics.UI.Gtk.WebKit.WebDataSource import Graphics.UI.Gtk.WebKit.WebFrame-import Graphics.UI.Gtk.WebKit.WebSettings import Graphics.UI.Gtk.WebKit.WebView  import Network.URL@@ -33,13 +46,12 @@ import System.Directory import System.Glib.Signals import System.IO-import System.Process import System.Posix.Process+import System.Posix.Signals import qualified System.ZMQ as ZMQ -- }}}  -- {{{ Commandline options--- | Available commandline options cliOptions :: CliOptions cliOptions = CliOptions {     mURI = def &= help "URI to open at start-up" &= explicit &= name "u" &= name "uri" &= typ "URI"@@ -49,13 +61,13 @@ getOptions = cmdArgs $ cliOptions     &= verbosityArgs [explicit, name "Verbose", name "v"] []     &= versionArg [ignore]-    &= help "A suckless minimal KISSy browser."+    &= help "A minimal KISS-compliant browser."     &= helpArg [explicit, name "help", name "h"]     &= program "hbro" -- }}} --- {{{ Configuration-dyreParameters :: D.Params Configuration+-- {{{ Configuration (Dyre)+dyreParameters :: D.Params Config dyreParameters = D.defaultParams {     D.projectName  = "hbro",     D.showError    = showError,@@ -64,19 +76,20 @@     D.statusOut    = hPutStrLn stderr } -showError :: Configuration -> String -> Configuration-showError configuration message = configuration { mError = Just message }+showError :: Config -> String -> Config+showError config message = config { mError = Just message }  -- | Default configuration.--- Does quite nothing.-defaultConfiguration :: Configuration-defaultConfiguration = Configuration {-    mHomePage    = "https://www.google.com",-    mSocketDir   = "/tmp/",-    mUIFile      = "~/.config/hbro/ui.xml",-    mKeys        = [],-    mWebSettings = webSettingsNew,-    mSetup       = \_ -> return () :: IO (),+-- Homepage: Google, socket directory: /tmp,+-- UI file: ~/.config/hbro/, no key/command binding.+defaultConfig :: FilePath -> FilePath -> Config +defaultConfig home tmp = Config {+    mHomePage    = "https://encrypted.google.com/",+    mSocketDir   = tmp,+    mUIFile      = home ++ "/.config/hbro/ui.xml",+    mKeys        = const [],+    mWebSettings = [],+    mSetup       = const (return () :: IO ()),     mCommands    = [],     mError       = Nothing }@@ -84,73 +97,58 @@  -- {{{ Entry point -- | Browser's main function.--- To be called in function "main" with a proper configuration.-hbro :: Configuration -> IO ()-hbro = D.wrapMain dyreParameters+-- To be called in main function with a proper configuration.+-- See Hbro.Main for an example.+launchHbro :: Config -> IO ()+launchHbro = D.wrapMain dyreParameters --- | Entry point for the application.--- Parse commandline arguments, print configuration error if any,--- create browser and load homepage.-realMain :: Configuration -> IO ()+realMain :: Config -> IO () realMain config = do+-- Print configuration error, if any+    maybe (return ()) putStrLn $ mError config+ -- Parse commandline arguments     options <- getOptions  -- Print in-use paths-    (a, b, c, d, e) <- getPaths dyreParameters-    whenLoud $ do+    getPaths dyreParameters >>= \(a,b,c,d,e) -> whenLoud $ do          putStrLn ("Current binary:  " ++ a)         putStrLn ("Custom binary:   " ++ b)         putStrLn ("Config file:     " ++ c)         putStrLn ("Cache directory: " ++ d)         putStrLn ("Lib directory:   " ++ e)         putStrLn ""---- Print configuration error, if any-    maybe (return ()) putStrLn $ mError config-+         -- Initialize GUI-    _   <- initGUI-    gui <- loadGUI $ mUIFile config-    let browser = Browser options config gui-    let webView = mWebView gui-    let window  = mWindow gui--    _ <- onDestroy window mainQuit-    widgetShowAll window-    showPrompt False browser ---- Load additionnal settings from configuration-    settings <- mWebSettings config-    webViewSetWebSettings webView settings-    (mSetup config) browser+    gui <- initGUI (mUIFile config) (mWebSettings config) --- Load key bindings-    let keyBindings = importKeyBindings (mKeys config)+-- Initialize IPC socket+    ZMQ.withContext 1 $ realMain' config options gui --- On new window request-    _ <- on webView createWebView $ \frame -> do-        newUri <- webFrameGetUri frame-        case newUri of-            Just uri -> do-                whenLoud $ putStrLn ("Requesting new window: " ++ uri ++ "...")-                webViewLoadUri webView uri-            Nothing  -> return ()-        return webView+realMain' :: Config -> CliOptions -> GUI -> ZMQ.Context -> IO ()+realMain' config options gui@GUI {mWebView = webView, mWindow = window} context = let+    environment = Environment options config gui context+    keys        = importKeyBindings $ (mKeys config) environment+    setup       = mSetup config+    socketDir   = mSocketDir config +    commands    = mCommands config+  in do+-- Apply custom setup+    setup environment  -- Manage keys-    _ <- after webView keyPressEvent $ do+    _ <- after window keyPressEvent $ do         value      <- eventKeyVal         modifiers  <- eventModifier          let keyString = keyToString value          case keyString of -            Just "<Escape>" -> liftIO $ showPrompt False browser+            Just "<Escape>" -> liftIO $ widgetHide ((mBox . mPromptBar) gui)             Just string -> do -                case Map.lookup (Set.fromList modifiers, string) keyBindings of+                case Map.lookup (Set.fromList modifiers, string) keys of                     Just callback -> do-                        liftIO $ callback browser+                        liftIO $ callback                         liftIO $ whenLoud (putStrLn $ "Key pressed: " ++ show modifiers ++ string ++ " (mapped)")                     _ -> liftIO $ whenLoud (putStrLn $ "Key pressed: " ++ show modifiers ++ string ++ " (unmapped)")             _ -> return ()@@ -162,164 +160,116 @@         Just uri -> do              fileURI <- doesFileExist uri             case fileURI of-                True -> getCurrentDirectory >>= \cwd -> webViewLoadUri webView $ "file://" ++ cwd ++ "/" ++ uri+                True -> getCurrentDirectory >>= \dir -> webViewLoadUri webView $ "file://" ++ dir ++ "/" ++ uri                 _    -> webViewLoadUri webView uri                          whenLoud $ putStrLn ("Loading " ++ uri ++ "...")-        _ -> goHome browser-+        _ -> goHome webView config --- Initialize IPC socket-    pid <- getProcessID-    let socketURI = "ipc://" ++ (mSocketDir config) ++ "/hbro." ++ show pid+-- Open socket+    pid              <- getProcessID+    let commandsList =  Map.fromList $ defaultCommandsList ++ commands+    let socketURI    =  "ipc://" ++ socketDir ++ "/hbro." ++ show pid+    void $ forkIO (openRepSocket context socketURI (listenToCommands environment commandsList))+    +-- Manage POSIX signals+    void $ installHandler sigINT (Catch interruptHandler) Nothing      --timeoutAdd (putStrLn "OK" >> return True) 2000--    ZMQ.withContext 1 $ \context -> do-        _ <- forkIO $ createRepSocket context socketURI browser-    -        mainGUI -- Main loop+    mainGUI -- Main loop -    -- Make sure response socket is closed at exit-        whenLoud $ putStrLn "Closing socket..."-        ZMQ.withSocket context ZMQ.Req $ \reqSocket -> do-            ZMQ.connect reqSocket socketURI-            ZMQ.send reqSocket (pack "Quit") []-            _ <- ZMQ.receive reqSocket []-            return ()+-- Make sure response socket is closed at exit+    whenLoud $ putStrLn "Closing socket..."+    closeSocket context socketURI+    whenNormal $ putStrLn "Exiting..." -        whenNormal $ putStrLn "Exiting..."+interruptHandler :: IO ()+interruptHandler = do+    whenLoud $ putStrLn "Received SIGINT."+    mainQuit -- }}}  -- {{{ Browsing functions -- | Load homepage (set from configuration file).-goHome :: Browser -> IO ()-goHome browser = do+goHome :: WebView -> Config -> IO ()+goHome webView config = do     whenLoud $ putStrLn ("Loading homepage: " ++ uri)-    loadURI uri browser+    loadURI webView uri   where-    uri = mHomePage $ mConfiguration browser---- | Wrapper around webViewGoBack function, provided for convenience.-goBack :: Browser -> IO ()-goBack browser = webViewGoBack (mWebView $ mGUI browser)---- | Wrapper around webViewGoForward function, provided for convenience.-goForward :: Browser -> IO ()-goForward browser = webViewGoForward (mWebView $ mGUI browser)---- | Wrapper around webViewStopLoading function, provided for convenience.-stopLoading :: Browser -> IO ()-stopLoading browser = webViewStopLoading (mWebView $ mGUI browser)---- | Wrapper around webViewReload{BypassCache}.-reload -    :: Bool     -- ^ If False, cache is bypassed.-    -> Browser-    -> IO ()-reload True browser = webViewReload             (mWebView $ mGUI browser)-reload _    browser = webViewReloadBypassCache  (mWebView $ mGUI browser)---- | Load given URL in the browser.-loadURI :: String -> Browser -> IO ()-loadURI url browser =-    case importURL url of-        Just url' -> do-            whenLoud $ putStrLn ("Loading URI: " ++ url)-            loadURI' url' browser-        _ -> putStrLn $ "WARNING: not a valid URI: " ++ url---- | Backend function for loadURI.-loadURI' :: URL -> Browser -> IO ()-loadURI' uri@URL {url_type = Absolute _} browser =-    webViewLoadUri (mWebView $ mGUI browser) (exportURL uri)-loadURI' uri@URL {url_type = HostRelative} browser = -    webViewLoadUri (mWebView $ mGUI browser) ("file://" ++ exportURL uri)-loadURI' uri@URL {url_type = _} browser = -    webViewLoadUri (mWebView $ mGUI browser) ("http://" ++ exportURL uri)--- }}}----- {{{ Zoom--- | Wrapper around webViewZoomIn function, provided for convenience.-zoomIn :: Browser -> IO ()-zoomIn browser = webViewZoomIn (mWebView $ mGUI browser)+    uri = mHomePage config --- | Wrapper around webViewZoomOut function, provided for convenience.-zoomOut :: Browser -> IO ()-zoomOut browser = webViewZoomOut (mWebView $ mGUI browser)+-- | Wrapper around webViewLoadUri meant to transparently add the proper protocol prefix (http:// or file://).+-- Most of the time, you want to use this function instead of webViewLoadUri.+loadURI :: WebView -> String -> IO ()+loadURI webView uri = do+    whenLoud $ putStrLn ("Loading URI: " ++ uri)+    case importURL uri of+        Just uri'@URL {url_type = Absolute _}   -> webViewLoadUri webView (exportURL uri')+        Just uri'@URL {url_type = HostRelative} -> webViewLoadUri webView ("file://" ++ exportURL uri')+        Just uri'@URL {url_type = _}            -> webViewLoadUri webView ("http://" ++ exportURL uri')+        _ -> whenNormal $ putStrLn ("WARNING: not a valid URI: " ++ uri) -- }}} ---- | Wrapper around webFramePrint function, provided for convenience.-printPage :: Browser -> IO()-printPage browser = do-    frame <- webViewGetMainFrame (mWebView $ mGUI browser)-    webFramePrint frame-- -- {{{ Scrolling -- | Scroll up to top of web page. Provided for convenience.-verticalHome :: Browser -> IO ()-verticalHome browser = do-    adjustment  <- scrolledWindowGetVAdjustment (mScrollWindow $ mGUI browser)+goTop :: ScrolledWindow -> IO ()+goTop window = do+    adjustment  <- scrolledWindowGetVAdjustment window     lower       <- adjustmentGetLower adjustment      adjustmentSetValue adjustment lower - -- | Scroll down to bottom of web page. Provided for convenience.-verticalEnd :: Browser -> IO ()-verticalEnd browser = do-    adjustment  <- scrolledWindowGetVAdjustment (mScrollWindow $ mGUI browser)+goBottom :: ScrolledWindow -> IO ()+goBottom window = do+    adjustment  <- scrolledWindowGetVAdjustment window     upper       <- adjustmentGetUpper adjustment      adjustmentSetValue adjustment upper  -- | Scroll to the left edge of web page. Provided for convenience.-horizontalHome :: Browser -> IO ()-horizontalHome browser = do-    adjustment  <- scrolledWindowGetHAdjustment (mScrollWindow $ mGUI browser)+goLeft :: ScrolledWindow -> IO ()+goLeft window = do+    adjustment  <- scrolledWindowGetHAdjustment window     lower       <- adjustmentGetLower adjustment      adjustmentSetValue adjustment lower  -- | Scroll to the right edge of web page. Provided for convenience.-horizontalEnd :: Browser -> IO ()-horizontalEnd browser = do-    adjustment  <- scrolledWindowGetHAdjustment (mScrollWindow $ mGUI browser)+goRight :: ScrolledWindow -> IO ()+goRight window = do+    adjustment  <- scrolledWindowGetHAdjustment window     upper       <- adjustmentGetUpper adjustment      adjustmentSetValue adjustment upper  -- }}} +-- {{{ Misc+-- | Wrapper around webFramePrint function, provided for convenience.+printPage :: WebView -> IO ()+printPage webView = do+    frame <- webViewGetMainFrame webView+    webFramePrint frame --- | Spawn a new instance of the browser.-newInstance :: IO ()-newInstance = do -    (binary, _, _, _, _) <- getPaths dyreParameters -    spawn $ proc binary []  -- | Execute a javascript file on current webpage.-executeJSFile :: String -> Browser -> IO ()-executeJSFile filePath browser = do+executeJSFile :: String -> WebView -> IO ()+executeJSFile filePath webView = do     whenNormal $ putStrLn ("Executing Javascript file: " ++ filePath)     script <- readFile filePath     let script' = unwords . map (\line -> line ++ "\n") . lines $ script -    webViewExecuteScript (mWebView $ mGUI browser) script'+    webViewExecuteScript webView script'+-- }}}   -- | Save current web page to a file, -- along with all its resources in a separated directory. -- Doesn't work for now, because web_resource_get_data's binding is missing...-savePage :: String -> Browser -> IO ()-savePage _path browser = do+_savePage :: String -> WebView -> IO ()+_savePage _path webView = do     frame        <- webViewGetMainFrame webView     dataSource   <- webFrameGetDataSource frame     _mainResource <- webDataSourceGetMainResource dataSource     _subResources <- webDataSourceGetSubresources dataSource     return ()-    -  where-    webView  = mWebView $ mGUI browser
Hbro/Extra/Bookmarks.hs view
@@ -1,134 +1,69 @@ module Hbro.Extra.Bookmarks (-    addWithTags,-    addAllWithTags,-    load,-    loadWithTag,+    select,+    selectTag,     deleteWithTag,     add, ) where  -- {{{ Imports-import Hbro.Core-import Hbro.Gui-import Hbro.Types+--import Hbro.Core+--import Hbro.Gui+--import Hbro.Types import Hbro.Util -import qualified Data.ByteString.Char8 as B+--import qualified Data.ByteString.Char8 as B import Data.List import qualified Data.Text as T import qualified Data.Text.IO as T--import Graphics.UI.Gtk.Entry.Entry-import Graphics.UI.Gtk.WebKit.WebView--import System.Environment-import qualified System.Info as Sys-import System.IO-import System.Posix.Process-import System.Process -import System.ZMQ  -- }}}  --- | Add current URI to bookmarks.--- Prompt for a tags list to apply.-addWithTags :: Browser -> IO ()-addWithTags browser = do-    uri <- webViewGetUri (mWebView $ mGUI browser) -    case uri of-        Just u -> prompt "Bookmark with tags:" "" False browser (\b -> do -            tags <- entryGetText (mPromptEntry $ mGUI b)-            add u (words tags)) -        _ -> return ()+-- | The elementary bookmark action+add :: FilePath -> String -> [String] -> IO ()+add bookmarksFile uri tags = appendFile bookmarksFile $ uri ++ " " ++ (unwords tags) ++ "\n" --- | Add current URIs from all opened windows to bookmarks.-addAllWithTags :: Browser -> IO ()-addAllWithTags browser = -    prompt "Bookmark all instances with tag:" "" False browser (\b -> do -        tags          <- entryGetText (mPromptEntry $ mGUI b)-        uri           <- webViewGetUri (mWebView $ mGUI browser)-        case uri of-            Just u -> add u $ words tags-            _      -> return () -        (_, pids, _)  <- readProcessWithExitCode "pidof" ["hbro"] []-        (_, pids', _) <- readProcessWithExitCode "pidof" ["hbro-" ++ Sys.os ++ "-" ++ Sys.arch] []-        myPid         <- getProcessID--        let pidsList    = delete (show myPid) . nub . words $ pids ++ " " ++ pids'-        let bookmarkPID = (\pid -> withContext 1 $ \context -> do-            withSocket context Req $ \reqSocket ->-              let -                socketURI = "ipc://" ++ (mSocketDir $ mConfiguration browser) ++ "/hbro." ++ pid-              in do-                connect reqSocket socketURI--                send reqSocket (B.pack "getUri") []-                uri' <- receive reqSocket []--                add (B.unpack uri') (words tags)-            )--        _ <- mapM bookmarkPID pidsList-        return ())- -- |-load :: Browser -> IO ()-load browser = do -    -- Load bookmarks file-    configHome  <- getEnv "XDG_CONFIG_HOME"-    file        <- T.readFile $ configHome ++ "/hbro/bookmarks"--    -- Reformat lines+select :: FilePath -> [String] -> IO (Maybe String)+select bookmarksFile dmenuOptions = do+-- Load bookmarks file+    file <- T.readFile bookmarksFile     let file' = T.unlines . sort . nub $ map reformat (T.lines file) -    -- Let user select a URI-    (Just input, Just output, _, _) <- createProcess (proc "dmenu" ["-l", "10"]) {-        std_in = CreatePipe,-        std_out = CreatePipe }-    _ <- T.hPutStr input file'+-- Let user select a URI+    selection <- dmenu dmenuOptions file' -    entry <- catch (hGetLine output) (\_error -> return "ERROR" )-    case reverse . words $ entry of-        ["ERROR"]   -> return ()-        uri:_       -> loadURI uri browser-        _           -> return ()+    case reverse . words $ selection of+        []          -> return Nothing+        uri:_       -> return $ Just uri     reformat :: T.Text -> T.Text-reformat line =-    T.unwords $ tags' ++ [uri]+reformat line = T.unwords $ tags' ++ [uri]   where     uri:tags = T.words line      tags'    = sort $ map (\tag -> T.snoc (T.cons '[' tag) ']') tags  -- | -loadWithTag :: IO ()        -loadWithTag = do+selectTag :: FilePath -> [String] -> IO (Maybe [String])+selectTag bookmarksFile dmenuOptions = do     -- Read bookmarks file-    configHome  <- getEnv "XDG_CONFIG_HOME"-    file        <- T.readFile $ configHome ++ "/hbro/bookmarks"+    file <- T.readFile bookmarksFile      -- Filter tags list     let list = T.unlines . sort . nub . T.words . T.unwords $ map getTags (T.lines file)      -- Let user select a tag-    (Just input, Just output, _, _) <- createProcess (proc "dmenu" ["-l", "10"]) {-        std_in = CreatePipe,-        std_out = CreatePipe }-    _ <- T.hPutStr input list+    selection <- dmenu dmenuOptions list -    tag <- catch (hGetLine output) (\_error -> return "ERROR" )-    case tag of-        "ERROR" -> return ()-        ""      -> return ()-        t       -> do-            _ <- mapM (\uri -> spawn (proc "hbro" ["-u", (T.unpack uri)])) uris-            return ()+    case selection of+        ""  -> return Nothing+        tag -> return $ Just uris+--mapM (\uri -> spawn "hbro" ["-u", (T.unpack uri)]) uris >> return ()           where-            file' = filter (tagFilter $ T.pack t) (T.lines file)-            uris  = map getUri file'+            file' = filter (tagFilter $ T.pack tag) (T.lines file)+            uris  = map (T.unpack . getUri) file'  --  tagFilter :: T.Text -> T.Text -> Bool@@ -138,35 +73,21 @@   -- |-deleteWithTag :: IO ()-deleteWithTag = do-    configHome  <- getEnv "XDG_CONFIG_HOME"-    file        <- T.readFile $ configHome ++ "/hbro/bookmarks"+deleteWithTag :: FilePath -> [String] -> IO ()+deleteWithTag bookmarksFile dmenuOptions = do+    file <- T.readFile bookmarksFile      let tagsList = T.unlines . sort . nub . T.words . T.unwords $ map getTags (T.lines file) -    (Just input, Just output, _, _) <- createProcess (proc "dmenu" []) {-        std_in = CreatePipe,-        std_out = CreatePipe }-    _ <- T.hPutStr input tagsList--    tag <- catch (hGetLine output) (\_error -> return "ERROR" )-    case tag of-        "ERROR" -> return ()+    selection <- dmenu dmenuOptions tagsList+    case selection of         ""      -> return ()         _       -> do-            T.writeFile (configHome ++ "/hbro/bookmarks.old") file-            T.writeFile (configHome ++ "/hbro/bookmarks")     file'+            T.writeFile (bookmarksFile ++ ".old") file+            T.writeFile bookmarksFile file'             return ()           where-            file' = T.unlines $ filter (not . (tagFilter $ T.pack tag)) (T.lines file)----- | The elementary bookmark action-add :: String -> [String] -> IO ()-add uri tags = do-    configHome  <- getEnv "XDG_CONFIG_HOME"-    appendFile (configHome ++ "/hbro/bookmarks") $ uri ++ " " ++ (unwords tags) ++ "\n"+            file' = T.unlines $ filter (not . (tagFilter $ T.pack selection)) (T.lines file)  -- | getTags :: T.Text -> T.Text
Hbro/Extra/BookmarksQueue.hs view
@@ -1,53 +1,39 @@ module Hbro.Extra.BookmarksQueue where  -- {{{ Imports-import Hbro.Types+--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 ()+--append :: String -> IO ()+--append bookmarksFile uri = do+--    configHome  <- getEnv "XDG_CONFIG_HOME"+--    appendFile (configHome ++ "/hbro/queue") (uri ++ "\n")  -- | 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") (\_error -> 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'+push :: String -> String -> IO ()+push bookmarksFile uri = do+    file        <- catch (T.readFile bookmarksFile) (\_error -> return T.empty) -                    return ()-        _ -> return ()+    if (file == T.empty)+      then return ()+      else do+        let fileLines = T.lines file+        let file' = T.unlines . nub $ (T.pack uri):fileLines+        +        T.writeFile bookmarksFile file'+        +        return ()  -- | Return the first URI from the queue, while removing it.-popFront :: IO String-popFront = do-    configHome  <- getEnv "XDG_CONFIG_HOME"-    file        <- catch (T.readFile $ configHome ++ "/hbro/queue") (\_error -> return T.empty)+popFront :: String -> IO String+popFront bookmarksFile = do+    file        <- catch (T.readFile bookmarksFile) (\_error -> return T.empty)      if file == T.empty         then return ""@@ -55,16 +41,15 @@             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'+            T.writeFile (bookmarksFile ++ ".old") file+            T.writeFile bookmarksFile file'              return $ T.unpack (head fileLines)  -- | Return the last URI from the queue, while removing it.-popBack :: IO String-popBack = do-    configHome  <- getEnv "XDG_CONFIG_HOME"-    file        <- catch (T.readFile $ configHome ++ "/hbro/queue") (\_error -> return T.empty)+popBack :: String -> IO String+popBack bookmarksFile = do+    file        <- catch (T.readFile bookmarksFile) (\_error -> return T.empty)      if file == T.empty         then return ""@@ -72,8 +57,8 @@             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'+            T.writeFile (bookmarksFile ++ ".old") file+            T.writeFile bookmarksFile file'              return $ T.unpack (head $ reverse fileLines)
Hbro/Extra/Clipboard.hs view
@@ -1,54 +1,21 @@ module Hbro.Extra.Clipboard where  -- {{{ Imports-import Hbro.Core-import Hbro.Types-import Hbro.Util+--import Hbro.Core+--import Hbro.Types+--import Hbro.Util -import Graphics.UI.Gtk.Abstract.Widget import Graphics.UI.Gtk.General.Clipboard-import Graphics.UI.Gtk.WebKit.WebView--import System.Process -- }}}   -- | Copy current URI in clipboard.-copyUri :: Browser -> IO ()-copyUri browser = do-    getUri <- webViewGetUri (mWebView $ mGUI browser)-    primaryClip <- widgetGetClipboard (mWindow $ mGUI browser) selectionPrimary--    case getUri of-        Just u -> clipboardSetText primaryClip u-        _      -> return ()---- | Copy current page title in clipboard.-copyTitle :: Browser -> IO ()-copyTitle browser = do-    getTitle    <- webViewGetTitle (mWebView $ mGUI browser)-    primaryClip <- widgetGetClipboard (mWindow $ mGUI browser) selectionPrimary--    case getTitle of-        Just t -> clipboardSetText primaryClip t-        _      -> return ()---- | Load URI from clipboard.-loadURIFromClipboard :: Browser -> IO ()-loadURIFromClipboard browser = do-    primaryClip <- widgetGetClipboard (mWindow $ mGUI browser) selectionPrimary--    _ <- clipboardRequestText primaryClip $ \x -> case x of-        Just uri -> putStrLn ("Loading URI from clipboard: " ++ uri) >> loadURI uri browser-        _        -> putStrLn "Loading URI from clipboard: empty clipboard."-    return ()---- | Load URI from clipboard in a new instance of the browser.-newInstanceFromClipboard :: Browser -> IO ()-newInstanceFromClipboard browser = do-    primaryClip <- widgetGetClipboard (mWindow $ mGUI browser) selectionPrimary--    _ <- clipboardRequestText primaryClip $ \x -> case x of-        Just uri -> putStrLn ("Loading URI from clipboard in new instance: " ++ uri) >> spawn (proc "hbro" ["-u", uri])-        _        -> putStrLn "Loading URI from clipboard in new instance: empty clipboard."-    return ()+toClipboard :: String -> IO ()+toClipboard text = do+    primaryClip <- clipboardGet selectionPrimary+    clipboardSetText primaryClip text+    +withClipboard :: (Maybe String -> IO ()) -> IO ()+withClipboard callback = do+    primaryClip <- clipboardGet selectionPrimary+    clipboardRequestText primaryClip callback
Hbro/Extra/History.hs view
@@ -1,49 +1,44 @@ module Hbro.Extra.History where  -- {{{ Imports-import Hbro.Core-import Hbro.Types+--import Hbro.Core+--import Hbro.Types+import Hbro.Util +--import Control.Monad.Reader+ import Data.List+import qualified Data.Text as T+import qualified Data.Text.IO as T import Data.Time -import System.Environment-import System.Exit import System.Locale-import System.Process  -- }}}    -- |-addToHistory :: String -> String -> IO ()-addToHistory uri title = do+add :: FilePath -> String -> String -> IO ()+add historyFile uri title = do     now        <- getCurrentTime-    configHome <- getEnv "XDG_CONFIG_HOME"     let time    = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" now-    appendFile (configHome ++ "/hbro/history") $ time ++ " " ++ uri ++ " " ++ title ++ "\n"+    appendFile historyFile $ time ++ " " ++ uri ++ " " ++ title ++ "\n"  -- |-loadFromHistory :: Browser -> IO ()-loadFromHistory browser = do-    configHome  <- getEnv "XDG_CONFIG_HOME"-    file        <- readFile $ configHome ++ "/hbro/history"+select :: FilePath -> [String] -> IO (Maybe String)+select historyFile dmenuOptions  = do+    file <- T.readFile historyFile -    let file' = unlines . nub $ map reformat (sort . lines $ file)+    let file' = T.unlines . nub $ map reformat (sort . T.lines $ file) -    (code, result, e) <- readProcessWithExitCode "dmenu" ["-l", "10"] file'-    return ()-    case (code, result) of-        (ExitSuccess, r) -> -          let-            uri:_ = words $ r-          in-            loadURI uri browser-        _ -> putStrLn e+    selection <- dmenu dmenuOptions file'+    case selection of+        ""    -> return Nothing+        entry -> return $ Just ((head . words) entry) -  where-    reformat line =-      let-        _date:_time:uri:title = words line -      in -        unwords $ [uri] ++ title+reformat :: T.Text -> T.Text+reformat line = +  let+        _date:_time:uri:title = T.words line +  in +        T.unwords $ [uri] ++ title
Hbro/Extra/Misc.hs view
@@ -1,100 +1,80 @@ module Hbro.Extra.Misc where  -- {{{ Imports-import Hbro.Core hiding(goBack, goForward)-import Hbro.Types+--import Hbro.Core+--import Hbro.Types import Hbro.Util  import Data.Maybe+import qualified Data.Text as T+import qualified Data.Text.IO as T -import Graphics.UI.Gtk.Builder import Graphics.UI.Gtk.Display.Label import Graphics.UI.Gtk.WebKit.WebBackForwardList import Graphics.UI.Gtk.WebKit.WebHistoryItem import Graphics.UI.Gtk.WebKit.WebView  import System.IO-import System.Process  -- }}}   -- | Same as goBack function from Hbro.Core, -- but with feedback in case of failure.-goForward :: Browser -> IO ()-goForward browser = do-    result        <- webViewCanGoForward webView-    feedbackLabel <- builderGetObject builder castToLabel "feedback"--    case result of-        True -> webViewGoForward webView-        _    -> labelSetMarkupTemporary feedbackLabel "<span foreground=\"red\">Unable to go forward !</span>" 5000 >> return ()--  where-    webView = mWebView $ mGUI browser-    builder = mBuilder $ mGUI browser---- | Same as goBack function from Hbro.Core,--- but with feedback in case of failure.-goBack :: Browser -> IO ()-goBack browser = do-    result        <- webViewCanGoBack webView-    feedbackLabel <- builderGetObject builder castToLabel "feedback"--    case result of-        True -> webViewGoBack webView-        _    -> labelSetMarkupTemporary feedbackLabel "<span foreground=\"red\">Unable to go back !</span>" 5000 >> return ()--  where-    webView = mWebView $ mGUI browser-    builder = mBuilder $ mGUI browser+--goForward :: WebView -> IO ()+--goForward webView = do+--    result        <- webViewCanGoForward webView+--    feedbackLabel <- builderGetObject builder castToLabel "feedback"+-- +--    case result of+--        True -> webViewGoForward webView+--        _    -> labelSetMarkupTemporary feedbackLabel "<span foreground=\"red\">Unable to go forward !</span>" 5000 >> return ()+-- +--  where+--    webView = mWebView $ mGUI browser+--    builder = mBuilder $ mGUI browser+-- +---- | Same as goBack function from Hbro.Core,+---- but with feedback in case of failure.+--goBack :: Browser -> IO ()+--goBack browser = do+--    result        <- webViewCanGoBack webView+--    feedbackLabel <- builderGetObject builder castToLabel "feedback"+-- +--    case result of+--        True -> webViewGoBack webView+--        _    -> labelSetMarkupTemporary feedbackLabel "<span foreground=\"red\">Unable to go back !</span>" 5000 >> return ()+-- +--  where+--    webView = mWebView $ mGUI browser+--    builder = mBuilder $ mGUI browser   -- | List preceding URIs in dmenu and let the user select which one to load.-goBackList :: Browser -> IO ()-goBackList browser = do+goBackList :: WebView -> [String] -> IO (Maybe String)+goBackList webView dmenuOptions = do     list           <- webViewGetBackForwardList webView     n              <- webBackForwardListGetBackLength list     backList       <- webBackForwardListGetBackListWithLimit list n     dmenuList      <- mapM itemToEntry backList--    (Just input, Just output, _, _) <- createProcess (proc "dmenu" ["-l", "10"]) {-        std_in = CreatePipe,-        std_out = CreatePipe }--    _     <- hPutStr input $ unlines (catMaybes dmenuList)-    entry <- catch (hGetLine output) (\_error -> return "ERROR" )+    selection      <- dmenu dmenuOptions $ (T.pack . unlines) (catMaybes dmenuList) -    case words entry of-        ["ERROR"]   -> return ()-        uri:_       -> loadURI uri browser-        _           -> return ()-    return ()-  where-    webView = mWebView $ mGUI browser+    case words selection of+        uri:_ -> return $ Just uri+        _     -> return Nothing       -- | List succeeding URIs in dmenu and let the user select which one to load.-goForwardList :: Browser -> IO ()-goForwardList browser = do+goForwardList :: WebView -> [String] -> IO (Maybe String)+goForwardList webView dmenuOptions = do     list        <- webViewGetBackForwardList webView     n           <- webBackForwardListGetForwardLength list     forwardList <- webBackForwardListGetForwardListWithLimit list n     dmenuList   <- mapM itemToEntry forwardList--    (Just input, Just output, _, _) <- createProcess (proc "dmenu" ["-l", "10"]) {-        std_in = CreatePipe,-        std_out = CreatePipe }--    _     <- hPutStr input $ unlines (catMaybes dmenuList)-    entry <- catch (hGetLine output) (\_error -> return "ERROR" )--    case words entry of-        ["ERROR"]   -> return ()-        uri:_       -> loadURI uri browser-        _           -> return ()-    return ()-  where-    webView = mWebView $ mGUI browser+    selection   <- dmenu dmenuOptions $ (T.pack . unlines) (catMaybes dmenuList)+    +    case words selection of+        uri:_       -> return $ Just uri+        _           -> return Nothing   itemToEntry :: WebHistoryItem -> IO (Maybe String)@@ -108,8 +88,8 @@  -- | Toggle source display. -- Current implementation forces a refresh of current web page, which may be undesired.-toggleSourceMode :: Browser -> IO ()-toggleSourceMode browser = do-    currentMode <- webViewGetViewSourceMode (mWebView $ mGUI browser)-    webViewSetViewSourceMode (mWebView $ mGUI browser) (not currentMode)-    reload True browser+toggleSourceMode :: WebView -> IO ()+toggleSourceMode webView = do+    currentMode <- webViewGetViewSourceMode webView+    webViewSetViewSourceMode webView (not currentMode)+    webViewReload webView
− Hbro/Extra/Prompt.hs 
@@ -1,40 +0,0 @@-module Hbro.Extra.Prompt where---- {{{ Imports-import Hbro.Core-import Hbro.Gui-import Hbro.Types--import Graphics.UI.Gtk.Entry.Entry-import Graphics.UI.Gtk.WebKit.WebView--- }}}----- | Prompt for key words to search in current webpage.-promptFind :: Bool -> Bool -> Bool -> Browser -> IO ()-promptFind caseSensitive forward wrap browser =-    prompt "Search" "" True browser (\browser' -> do-        keyWord <- entryGetText (mPromptEntry $ mGUI browser')-        _found  <- webViewSearchText (mWebView $ mGUI browser) keyWord caseSensitive forward wrap-        return ())---- | Switch to next found key word.-findNext :: Bool -> Bool -> Bool -> Browser -> IO ()-findNext caseSensitive forward wrap browser = do-    keyWord <- entryGetText (mPromptEntry $ mGUI browser)-    _found  <- webViewSearchText (mWebView $ mGUI browser) keyWord caseSensitive forward wrap -    return ()---- | Prompt for URI to open in current window.-promptURL :: Bool -> Browser -> IO ()-promptURL False browser = -    prompt "Open URL" "" False browser (\b -> do -        uri <- entryGetText (mPromptEntry $ mGUI 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)-                        loadURI u b)-        _ -> return ()
Hbro/Extra/Session.hs view
@@ -1,7 +1,7 @@ module Hbro.Extra.Session where  -- {{{ Imports-import Hbro.Types+--import Hbro.Types import Hbro.Util  import qualified Data.Text as T@@ -18,13 +18,12 @@ import System.Process  -- }}} -setupSession :: Browser -> IO ()-setupSession browser = do+setupSession :: WebView -> String -> IO ()+setupSession webView sessionDirectory = do     pid             <- getProcessID-    configHome      <- getEnv "XDG_CONFIG_HOME"-    previousSession <- getDirectoryContents (configHome ++ "/hbro/") >>= return . (filter sessionFilesFilter)+    previousSession <- getDirectoryContents sessionDirectory -    let sessionFile = configHome ++ "/hbro/session." ++ show pid+    let sessionFile = sessionDirectory ++ show pid      _ <- on webView loadFinished $ \_ -> do                 uri <- webViewGetUri webView@@ -38,39 +37,24 @@          return () -  where-    webView = mWebView $ mGUI browser -sessionFilesFilter :: String -> Bool-sessionFilesFilter ('s':'e':'s':'s':'i':'o':'n':'.':_) = True-sessionFilesFilter _ = False---loadFromSession :: Browser -> IO ()-loadFromSession browser = do-    configHome      <- getEnv "XDG_CONFIG_HOME"-    previousSession <- getDirectoryContents (configHome ++ "/hbro/") >>= return . (filter sessionFilesFilter)-    sessionURIs     <- mapM getSessionURI previousSession ---    (Just input, Just output, _, _) <- createProcess (proc "dmenu" ["-l", "10"]) {-        std_in = CreatePipe,-        std_out = CreatePipe }-    _ <- T.hPutStr input (T.unlines sessionURIs)-    -    uri <- catch (hGetLine output) (\_error -> return "ERROR" )-    -    case uri of-        "ERROR" -> return ()-        ""      -> return ()-        u       -> do-            _ <- spawn (proc "hbro" ["-u", u])-            return ()-    -getSessionURI :: String -> IO T.Text-getSessionURI fileName = do-    configHome  <- getEnv "XDG_CONFIG_HOME"-    file        <- T.readFile $ configHome ++ "/hbro/" ++ fileName--    return $ (head . T.lines) file+--loadFromSession :: [String] -> String -> IO ()+--loadFromSession dmenuOptions sessionDirectory = do+--    previousSession <- getDirectoryContents sessionDirectory+--    sessionURIs     <- mapM getSessionURI previousSession +-- +--    selection <- dmenu dmenuOptions (T.unlines sessionURIs)+--    +--    case selection of+--        ""      -> return ()+--        u       -> do+--            _ <- spawn "hbro" ["-u", u]+--            return ()+--    +--getSessionURI :: String -> IO T.Text+--getSessionURI fileName = do+--    configHome  <- getEnv "XDG_CONFIG_HOME"+--    file        <- T.readFile $ configHome ++ "/hbro/sessions/" ++ fileName+-- +--    return $ (head . T.lines) file
Hbro/Extra/StatusBar.hs view
@@ -1,7 +1,7 @@ module Hbro.Extra.StatusBar where  -- {{{ Imports-import Hbro.Types+--import Hbro.Types import Hbro.Util   import Control.Monad.Trans(liftIO)@@ -12,7 +12,6 @@ import Graphics.Rendering.Pango.Layout  import Graphics.UI.Gtk.Abstract.Widget-import Graphics.UI.Gtk.Builder import Graphics.UI.Gtk.Display.Label import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.Misc.Adjustment@@ -25,12 +24,14 @@ -- }}}  --- | Display scroll position in status bar.--- Needs a Label entitled "scroll" from the builder.-statusBarScrollPosition :: Browser -> IO ()-statusBarScrollPosition browser = do-    scrollLabel <- builderGetObject builder castToLabel "scroll"-    adjustment  <- scrolledWindowGetVAdjustment scrollWindow+-- | Write current scroll position in the given Label.+setupScrollWidget :: Label -> ScrolledWindow -> IO ()+setupScrollWidget widget window = do+    labelSetAttributes widget [+        AttrForeground {paStart = 0, paEnd = -1, paColor = Color 32767 32767 32767}+        ]+      +    adjustment  <- scrolledWindowGetVAdjustment window      _ <- onValueChanged adjustment $ do         current <- adjustmentGetValue    adjustment@@ -39,40 +40,26 @@         page    <- adjustmentGetPageSize adjustment                  case upper-lower-page of-            0 -> labelSetMarkup scrollLabel "ALL"-            x -> labelSetMarkup scrollLabel $ show (round $ current/x*100) ++ "%"--    labelSetMarkup scrollLabel "0%"+            0 -> labelSetText widget "ALL"+            x -> labelSetText widget $ show (round $ current/x*100) ++ "%" -  where-    builder      = mBuilder      (mGUI browser)-    scrollWindow = mScrollWindow (mGUI browser)+    labelSetText widget "0%"  --- | Display current zoom level in status bar.--- Needs a Label entitled "zoom" from the builder.-statusBarZoomLevel :: Browser -> IO ()-statusBarZoomLevel browser = do+-- | /!\ Doesn't work for now.+-- Write current zoom level in the given Label.+statusBarZoomLevel :: Label -> WebView -> IO ()+statusBarZoomLevel widget webView = do     zoomLevel <- webViewGetZoomLevel webView-    zoomLabel <- builderGetObject builder castToLabel "zoom"             -    labelSetMarkup zoomLabel $ "<span foreground=\"white\">x" ++ escapeMarkup (show zoomLevel) ++ "</span>"-  where-    builder = mBuilder (mGUI browser)-    webView = mWebView (mGUI browser)-+    labelSetMarkup widget $ "<span foreground=\"white\">x" ++ escapeMarkup (show zoomLevel) ++ "</span>"   -- | Display pressed keys in status bar. -- Needs a Label entitled "keys" from the builder.-statusBarPressedKeys :: Browser -> IO ()-statusBarPressedKeys browser = -  let-    builder         = mBuilder      (mGUI browser)-    webView         = mWebView      (mGUI browser)-  in do-    keysLabel <- builderGetObject builder castToLabel "keys"-    labelSetAttributes keysLabel [+statusBarPressedKeys :: Label -> WebView -> IO ()+statusBarPressedKeys widget webView = do+    labelSetAttributes widget [         AttrForeground {paStart = 0, paEnd = -1, paColor = Color 0 65535 0}         ]     @@ -82,61 +69,53 @@          let keyString = keyToString value         case (keyString, modifiers) of -            (Just k, [])    -> liftIO $ labelSetText keysLabel k-            (Just k, m)     -> liftIO $ labelSetText keysLabel (show m ++ k)+            (Just k, [])    -> liftIO $ labelSetText widget k+            (Just k, m)     -> liftIO $ labelSetText widget (show m ++ k)             _               -> return ()          return False     return ()  --- | Display load progress in status bar.--- Needs a Label entitled "progress" from the builder.-statusBarLoadProgress :: Browser -> IO ()-statusBarLoadProgress browser = -  let-    builder         = mBuilder      (mGUI browser)-    webView         = mWebView      (mGUI browser)-  in do-    progressLabel <- builderGetObject builder castToLabel "progress"+-- | Write current load progress in the given Label.+statusBarLoadProgress :: Label -> WebView -> IO ()+statusBarLoadProgress widget webView = do -- Load started     _ <- on webView loadStarted $ \_ -> do-        labelSetAttributes progressLabel [+        labelSetAttributes widget [             AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0}             ]-        labelSetText progressLabel "0%"+        labelSetText widget "0%" -- Progress changed         _ <- on webView progressChanged $ \progress' -> do-        labelSetAttributes progressLabel [+        labelSetAttributes widget [             AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 65535 0}             ]-        labelSetText progressLabel $ show progress' ++ "%"+        labelSetText widget $ show progress' ++ "%" -- Load finished     _ <- on webView loadFinished $ \_ -> do-        labelSetAttributes progressLabel [+        labelSetAttributes widget [             AttrForeground {paStart = 0, paEnd = -1, paColor = Color 0 65535 0}             ]-        labelSetText progressLabel "100%"+        labelSetText widget "100%" -- Error     _ <- on webView loadError $ \_ _ _ -> do-        labelSetAttributes progressLabel [+        labelSetAttributes widget [             AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0}             ]-        labelSetText progressLabel "ERROR"+        labelSetText widget "ERROR"         return False          return ()  --- | Display current URI, or the destination of a hovered link, in the status bar.--- Needs a Label named "uri" from the builder.-statusBarURI :: Browser -> IO ()-statusBarURI browser = do-    uriLabel <- builderGetObject builder castToLabel "uri"+-- | Write current URI, or the destination of a hovered link, in the given Label.+statusBarURI :: Label -> WebView -> IO ()+statusBarURI widget webView = do -- URI changed     _ <- on webView loadCommitted $ \_ -> do         getUri <- (webViewGetUri webView) -        maybe (return ()) (\x -> setURILabel x uriLabel) getUri+        maybe (return ()) (flip setURILabel widget) getUri  -- Hovering link     _ <- on webView hoveringOverLink $ \_title hoveredUri -> do@@ -146,21 +125,19 @@                              (_, Just u) -> u                              (_, _)      -> "ERROR"         -        setURILabel uri uriLabel+        setURILabel uri widget              return ()    where-    builder = mBuilder (mGUI browser)-    webView = mWebView (mGUI browser)     setURILabel uri label = do         let uri' = importURL uri         case uri' of             Just u -> do                 case url_type u of-                    Absolute host -> do-                        let host'           = exportHost host-                        let secure'         = secure host+                    Absolute host_ -> do+                        let host'           = exportHost host_+                        let secure'         = secure host_                         let protocolColor   = Color 20000 20000 20000                         let hostColor       = case secure' of                               True -> Color 0 65535 0
Hbro/Gui.hs view
@@ -1,23 +1,34 @@ {-# LANGUAGE DoRec #-}-module Hbro.Gui where+module Hbro.Gui (+    initGUI,+    showWebInspector,+    prompt,+    promptIncremental,+    toggleVisibility+) where  -- {{{ Imports import Hbro.Types -import Control.Monad.Trans(liftIO)+import Control.Monad+import Control.Monad.Trans  import Graphics.Rendering.Pango.Enums import Graphics.UI.Gtk.Abstract.Container+import Graphics.UI.Gtk.Abstract.Box import Graphics.UI.Gtk.Abstract.Widget import Graphics.UI.Gtk.Builder import Graphics.UI.Gtk.Display.Label import Graphics.UI.Gtk.Entry.Editable import Graphics.UI.Gtk.Entry.Entry-import Graphics.UI.Gtk.General.General+import qualified Graphics.UI.Gtk.General.General as GTK import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.Layout.HBox+import Graphics.UI.Gtk.Layout.VBox import Graphics.UI.Gtk.Scrolling.ScrolledWindow import Graphics.UI.Gtk.WebKit.WebInspector+import Graphics.UI.Gtk.WebKit.WebFrame+import Graphics.UI.Gtk.WebKit.WebSettings import Graphics.UI.Gtk.WebKit.WebView import Graphics.UI.Gtk.Windows.Window @@ -27,185 +38,218 @@ -- }}}  --- | Load GUI from XML file-loadGUI :: String -> IO GUI-loadGUI xmlPath = do+initGUI :: FilePath -> [AttrOp WebSettings] -> IO GUI+initGUI xmlPath settings = do     whenNormal $ putStr ("Loading GUI from " ++ xmlPath ++ "... ")+    void GTK.initGUI  -- Load XML     builder <- builderNew     builderAddFromFile builder xmlPath+ +-- Init components+    (webView, sWindow) <- initWebView        builder settings+    (window, wBox)     <- initWindow         builder webView+    promptBar          <- initPromptBar      builder+    statusBar          <- initStatusBar      builder+    inspectorWindow    <- initWebInspector   webView wBox+    +-- Show window+    widgetShowAll window+    widgetHide (mBox promptBar)+    +    whenNormal $ putStrLn "Done."+    return $ GUI window inspectorWindow sWindow webView promptBar statusBar builder --- Init main web view-    webView <- webViewNew+initWebView :: Builder -> [AttrOp WebSettings] -> IO (WebView, ScrolledWindow)+initWebView builder settings = do+    webView     <- webViewNew+    webSettings <- webSettingsNew+           +    set webSettings settings+         set webView [ widgetCanDefault := True ]-    _ <- on webView closeWebView $ do-        mainQuit-        return False+    _ <- on webView closeWebView $ GTK.mainQuit >> return False+    webViewSetWebSettings webView webSettings+        +-- On new window request+    _ <- on webView createWebView $ \frame -> do+        newUri <- webFrameGetUri frame+        case newUri of+            Just uri -> do+                whenLoud $ putStrLn ("Requesting new window: " ++ uri ++ "...")+                webViewLoadUri webView uri+            Nothing  -> return ()+        return webView+    +    window <- builderGetObject builder castToScrolledWindow "webViewParent"+    containerAdd window webView +    scrolledWindowSetPolicy window PolicyNever PolicyNever+    +    return (webView, window) --- Load main window-    window       <- builderGetObject builder castToWindow            "mainWindow"+initWindow :: Builder -> WebView -> IO (Window, VBox)+initWindow builder webView = do+    window <- builderGetObject builder castToWindow "mainWindow"     windowSetDefault window $ Just webView--    scrollWindow <- builderGetObject builder castToScrolledWindow    "webViewParent"-    containerAdd scrollWindow webView -    scrolledWindowSetPolicy scrollWindow PolicyNever PolicyNever+    windowSetDefaultSize window 800 600+    widgetModifyBg window StateNormal (Color 0 0 10000)+    _ <- onDestroy window GTK.mainQuit+    +    box <- builderGetObject builder castToVBox "windowBox"+    +    return (window, box) -    promptLabel  <- builderGetObject builder castToLabel             "promptDescription"-    labelSetAttributes promptLabel [+initPromptBar :: Builder -> IO PromptBar+initPromptBar builder = do+    label  <- builderGetObject builder castToLabel "promptDescription"+    labelSetAttributes label [       AttrStyle  {paStart = 0, paEnd = -1, paStyle = StyleItalic},       AttrWeight {paStart = 0, paEnd = -1, paWeight = WeightBold}       ]     -    promptEntry  <- builderGetObject builder castToEntry             "promptEntry"-    statusBox    <- builderGetObject builder castToHBox              "statusBox"---- Create web inspector's window-    inspector       <- webViewGetInspector webView-    inspectorWindow <- initWebInspector inspector+    entry <- builderGetObject builder castToEntry "promptEntry"+    box   <- builderGetObject builder castToHBox  "promptBox"     -    whenNormal $ putStrLn "Done."-    return $ GUI window inspectorWindow scrollWindow webView promptLabel promptEntry statusBox builder-+    return $ PromptBar box label entry+    +initStatusBar :: Builder -> IO HBox+initStatusBar builder = builderGetObject builder castToHBox "statusBox"+      -- {{{ Web inspector-initWebInspector :: WebInspector -> IO (Window)-initWebInspector inspector = do +initWebInspector :: WebView -> VBox -> IO (Window)+initWebInspector webView windowBox = do +    inspector       <- webViewGetInspector webView     inspectorWindow <- windowNew     set inspectorWindow [ windowTitle := "hbro | Web inspector" ]      _ <- on inspector inspectWebView $ \_ -> do-        webView <- webViewNew-        containerAdd inspectorWindow webView-        return webView+        view <- webViewNew+        containerAdd inspectorWindow view+        return view          _ <- on inspector showWindow $ do         widgetShowAll inspectorWindow         return True -    -- TODO: when does this signal happen ?!+-- TODO: when does this signal happen ?!     --_ <- on inspector finished $ return () ---     _ <- on inspector attachWindow $ do---         getWebView <- webInspectorGetWebView inspector---         case getWebView of---             Just webView -> do widgetHide (mInspectorWindow gui)---                                containerRemove (mInspectorWindow gui) webView---                                widgetSetSizeRequest webView (-1) 250---                                boxPackEnd (mWindowBox gui) webView PackNatural 0---                                widgetShow webView---                                return True---             _            -> return False+-- Attach inspector to browser's main window+    _ <- on inspector attachWindow $ do+        getWebView <- webInspectorGetWebView inspector+        case getWebView of+            Just view -> do +                widgetHide inspectorWindow+                containerRemove inspectorWindow view+                widgetSetSizeRequest view (-1) 250+                boxPackEnd windowBox view PackNatural 0+                widgetShow view+                return True+            _ -> return False ---     _ <- on inspector detachWindow $ do---         getWebView <- webInspectorGetWebView inspector---         _ <- case getWebView of---             Just webView -> do containerRemove (mWindowBox gui) webView---                                containerAdd (mInspectorWindow gui) webView---                                widgetShowAll (mInspectorWindow gui)---                                return True---             _            -> return False+-- Detach inspector in a distinct window+    _ <- on inspector detachWindow $ do+        getWebView <- webInspectorGetWebView inspector+        _ <- case getWebView of+            Just view -> do+                containerRemove windowBox view+                containerAdd inspectorWindow view+                widgetShowAll inspectorWindow+                return True+            _ -> return False         ---         widgetShowAll (mInspectorWindow gui)---         return True+        widgetShowAll inspectorWindow+        return True      return inspectorWindow   -- | Show web inspector for current webpage.-showWebInspector :: Browser -> IO ()-showWebInspector browser = do-    inspector <- webViewGetInspector (mWebView $ mGUI browser)+showWebInspector :: WebView -> IO ()+showWebInspector webView = do+    inspector <- webViewGetInspector webView     webInspectorInspectCoordinates inspector 0 0- -- }}}   -- {{{ Prompt--- | Show or hide the prompt bar (label + entry).-showPrompt :: Bool -> Browser -> IO ()-showPrompt toShow browser = case toShow of-    False -> do widgetHide (mPromptLabel $ mGUI browser)-                widgetHide (mPromptEntry $ mGUI browser)-    _     -> do widgetShow (mPromptLabel $ mGUI browser)-                widgetShow (mPromptEntry $ mGUI browser)+openPrompt :: PromptBar -> String -> String -> IO ()+openPrompt _promptBar@PromptBar {mBox = promptBox, mDescription = description, mEntry = entry} newDescription defaultText = do+    labelSetText description newDescription+    entrySetText entry defaultText+    +    widgetShow promptBox+    widgetGrabFocus entry+    editableSetPosition entry (-1)+    +-- | Open prompt bar with given description and default value,+-- and register a callback to trigger at validation.+prompt :: String -> String -> (String -> IO ()) -> PromptBar -> IO ()+prompt l d = prompt' l d False --- | Show the prompt bar label and default text.--- As the user validates its entry, the given callback is executed.-prompt :: String -> String -> Bool -> Browser -> (Browser -> IO ()) -> IO ()-prompt label defaultText incremental browser callback = let-        promptLabel = (mPromptLabel $ mGUI browser)-        promptEntry = (mPromptEntry $ mGUI browser)-        webView     = (mWebView     $ mGUI browser)-    in do-    -- Fill prompt-        labelSetText promptLabel label-        entrySetText promptEntry defaultText-        -    -- Focus on prompt-        showPrompt True browser-        widgetGrabFocus promptEntry-        editableSetPosition promptEntry (-1)+-- | Same as 'prompt', but callback is triggered for each change in prompt's entry.+promptIncremental :: String -> String -> (String -> IO ()) -> PromptBar -> IO ()+promptIncremental l d = prompt' l d True -    -- Register callback-        case incremental of-            True -> do -                id1 <- on promptEntry editableChanged $  -                    liftIO $ callback browser-                rec id2 <- on promptEntry keyPressEvent $ do-                    key <- eventKeyName-                    -                    case key of-                        "Return" -> do-                            liftIO $ showPrompt False browser-                            liftIO $ signalDisconnect id1-                            liftIO $ signalDisconnect id2-                            liftIO $ widgetGrabFocus webView-                        "Escape" -> do-                            liftIO $ showPrompt False browser-                            liftIO $ signalDisconnect id1-                            liftIO $ signalDisconnect id2-                            liftIO $ widgetGrabFocus webView-                        _ -> return ()-                    return False-                return ()+prompt' :: String -> String -> Bool -> (String -> IO ()) -> PromptBar -> IO ()+prompt' description defaultText incremental callback promptBar = do+    openPrompt promptBar description defaultText -            _ -> do-                rec id <- on promptEntry keyPressEvent $ do-                    key <- eventKeyName+-- Register callback+    case incremental of+        True -> do +            id1 <- on entry editableChanged $ entryGetText entry >>= callback+            rec id2 <- on entry keyPressEvent $ do+                key <- eventKeyName+                +                case key of+                    "Return" -> liftIO $ do+                        widgetHide promptBox+                        signalDisconnect id1+                        signalDisconnect id2+                        --widgetGrabFocus webView+                    "Escape" -> liftIO $ do+                        widgetHide promptBox+                        signalDisconnect id1+                        signalDisconnect id2+                        --widgetGrabFocus webView+                    _ -> return ()+                return False+            return () -                    case key of-                        "Return" -> do-                            liftIO $ showPrompt False browser-                            liftIO $ callback browser-                            liftIO $ signalDisconnect id-                            liftIO $ widgetGrabFocus webView-                        "Escape" -> do-                            liftIO $ showPrompt False browser-                            liftIO $ signalDisconnect id-                            liftIO $ widgetGrabFocus webView-                        _        -> return ()-                    return False+        _ -> do+            rec id <- on entry keyPressEvent $ do+                key  <- eventKeyName -                return ()+                case key of+                    "Return" -> liftIO $ do+                        widgetHide promptBox+                        entryGetText entry >>= callback+                        signalDisconnect id+                        --widgetGrabFocus webView+                    "Escape" -> liftIO $ do+                        widgetHide promptBox+                        signalDisconnect id+                        --widgetGrabFocus webView+                    _        -> return ()+                return False++            return ()+  where+    promptBox = mBox promptBar+    entry     = mEntry promptBar+    --webView   = (mWebView . mGUI) environment -- }}}   -- {{{ Util--- | Toggle statusbar's visibility-toggleStatusBar :: Browser -> IO ()-toggleStatusBar browser = do-    visibility <- get (mStatusBox $ mGUI browser) widgetVisible+-- | Toggle a widget's visibility (provided for convenience).+toggleVisibility :: WidgetClass a => a -> IO ()+toggleVisibility widget = do+    visibility <- get widget widgetVisible     case visibility of-        False -> widgetShow (mStatusBox $ mGUI browser)-        _     -> widgetHide (mStatusBox $ mGUI browser)----- | Set the window fullscreen-fullscreen :: Browser -> IO ()-fullscreen   browser = windowFullscreen   (mWindow $ mGUI browser)---- | Restore the window from fullscreen-unfullscreen :: Browser -> IO ()-unfullscreen browser = windowUnfullscreen (mWindow $ mGUI browser)+        False -> widgetShow widget+        _     -> widgetHide widget -- }}}
Hbro/Main.hs view
@@ -5,15 +5,20 @@ import Hbro.Types  import Paths_hbro++import System.Directory -- }}} +-- | Default main function provided as example. main :: IO () main = do+    home   <- getHomeDirectory+    tmp    <- getTemporaryDirectory     uiFile <- getDataFileName "examples/ui.xml"  --     putStrLn "[WARNING] You are running the default configuration which provides hardly no feature."---     putStrLn $ "[WARNING] You should copy the example configuration files hbro.hs and ui.xml in " ++ configHome ++ "/hbro and start hacking them."+--     putStrLn "[WARNING] You should copy the example configuration files hbro.hs and ui.xml in ~/.config/hbro/hbro and start hacking them." -    hbro defaultConfiguration {+    launchHbro $ (defaultConfig home tmp) {         mUIFile = uiFile     }
Hbro/Socket.hs view
@@ -1,8 +1,12 @@ module Hbro.Socket where      -- {{{ Imports+import Hbro.Util import Hbro.Types +import Control.Monad+import Control.Monad.Reader+ import Data.ByteString.Char8 (pack, unpack) import qualified Data.Map as Map @@ -15,20 +19,17 @@      -- | Create a response socket to listen for commands. -- Loops on listenToSocket until "Quit" command is received.-createRepSocket :: Context -> String -> Browser -> IO ()-createRepSocket context socketURI browser = do-    whenNormal $ putStrLn ("Listening socket at " ++ socketURI)+openRepSocket :: Context -> String -> (Socket Rep -> IO ()) -> IO ()+openRepSocket context socketURI listen = do    +    whenNormal $ putStrLn ("Opening socket at " ++ socketURI)     withSocket context Rep $ \repSocket -> do         bind repSocket socketURI-        listenToSocket repSocket commandsList browser-  where-    commandsList = Map.fromList (defaultCommandsList ++ (mCommands $ mConfiguration browser))-+        listen repSocket  -- | 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+listenToCommands :: Environment -> CommandsMap -> Socket Rep -> IO ()+listenToCommands environment commands repSocket = do     message      <- receive repSocket []     let message' =  unpack message @@ -36,71 +37,96 @@     -- Empty command         [] -> send repSocket (pack "ERROR Unknown command") []     -- Exit command-        ["Quit"] -> send repSocket (pack "OK") []+        ["QUIT"] -> do+            whenLoud $ putStrLn "Receiving QUIT command"+            send repSocket (pack "OK") []     -- Valid command         command:arguments -> do             whenLoud $ putStrLn ("Receiving command: " ++ message')             case Map.lookup command commands of-                Just callback -> callback arguments repSocket browser+                Just callback -> callback arguments repSocket environment                 _             -> send repSocket (pack "ERROR Unknown command") [] -            listenToSocket repSocket commands browser+            listenToCommands environment commands repSocket+         +-- | Close the response socket by sending it the command "Quit".+-- Typically called when exiting application.            +closeSocket :: Context -> String -> IO ()+closeSocket context socketURI = void $ sendCommand context socketURI "QUIT"+        +-- | Return the socket path to use for the given browser's process ID.+processIDToSocket :: String -> String -> String+processIDToSocket pid socketDir = "ipc://" ++ socketDir ++ "/hbro." ++ pid+  +-- | Send a single command (through a Request socket) to the given Response socket,+-- and return the answer.+sendCommand :: Context -> String -> String -> IO String+sendCommand context socketURI command = do+    withSocket context Req $ \reqSocket -> do+        connect reqSocket socketURI+        send reqSocket (pack command) []+        receive reqSocket [] >>= return . unpack+        +-- | Same as 'sendCommand', but for all running instances of the browser.+sendCommandToAll :: Context -> FilePath -> String -> IO [String]+sendCommandToAll context socketDir command = getAllProcessIDs >>= mapM (\pid -> sendCommand context (processIDToSocket pid socketDir) command)+ -- | List of default supported requests. defaultCommandsList :: CommandsList defaultCommandsList = [     -- Get information-    ("getUri", \_arguments repSocket browser -> do+    ("GET_URI", \_arguments repSocket browser -> liftIO $ do         getUri <- postGUISync $ webViewGetUri (mWebView $ mGUI browser)         case getUri of             Just uri -> send repSocket (pack uri) []             _        -> send repSocket (pack "ERROR No URL opened") [] ), -    ("getTitle", \_arguments repSocket browser -> do+    ("GET_TITLE", \_arguments repSocket browser -> liftIO $ 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+    ("GET_FAVICON_URI", \_arguments repSocket browser -> liftIO $ 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+    ("GET_LOAD_PROGRESS", \_arguments repSocket browser -> liftIO $ do         progress <- postGUISync $ webViewGetProgress (mWebView $ mGUI browser)         send repSocket (pack (show progress)) [] ),       -- Trigger actions-    ("loadUri", \arguments repSocket browser -> case arguments of +    ("LOAD_URI", \arguments repSocket browser -> liftIO $ case arguments of          uri:_ -> do             postGUIAsync $ webViewLoadUri (mWebView $ mGUI browser) uri             send repSocket (pack "OK") []         _     -> send repSocket (pack "ERROR: argument needed.") [] ), -    ("stopLoading", \_arguments repSocket browser -> do+    ("STOP_LOADING", \_arguments repSocket browser -> liftIO $do         postGUIAsync $ webViewStopLoading (mWebView $ mGUI browser)          send repSocket (pack "OK") [] ), -    ("reload", \_arguments repSocket browser -> do+    ("RELOAD", \_arguments repSocket browser -> liftIO $ do         postGUIAsync $ webViewReload (mWebView $ mGUI browser)         send repSocket (pack "OK") [] ), -    ("goBack", \_arguments repSocket browser -> do+    ("GO_BACK", \_arguments repSocket browser -> liftIO $ do         postGUIAsync $ webViewGoBack (mWebView $ mGUI browser)         send repSocket (pack "OK") [] ), -    ("goForward", \_arguments repSocket browser -> do+    ("GO_FORWARD", \_arguments repSocket browser -> liftIO $ do         postGUIAsync $ webViewGoForward (mWebView $ mGUI browser)         send repSocket (pack "OK") [] ), -    ("zoomIn", \_arguments repSocket browser -> do+    ("ZOOM_IN", \_arguments repSocket browser -> liftIO $ do         postGUIAsync $ webViewZoomIn (mWebView $ mGUI browser)         send repSocket (pack "OK") [] ), -    ("zoomOut", \_arguments repSocket browser -> do+    ("ZOOM_OUT", \_arguments repSocket browser -> liftIO $ do         postGUIAsync $ webViewZoomOut (mWebView $ mGUI browser)         send repSocket (pack "OK") [] )     ]
Hbro/Types.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} module Hbro.Types where  -- {{{ Imports@@ -15,14 +16,16 @@ import Graphics.UI.Gtk.Windows.Window  import System.Console.CmdArgs+import System.Glib.Attributes import System.ZMQ  -- }}}  -data Browser = Browser {-    mOptions        :: CliOptions,          -- ^ Commandline options-    mConfiguration  :: Configuration,       -- ^ Custom configuration provided by user-    mGUI            :: GUI                  -- ^ Graphical widgets+data Environment = Environment {+    mOptions :: CliOptions,          -- ^ Commandline options+    mConfig  :: Config,              -- ^ Configuration parameters (constants) provided by user+    mGUI     :: GUI,                 -- ^ Graphical widgets+    mContext :: Context              -- ^  }  data CliOptions = CliOptions {@@ -30,15 +33,16 @@ } deriving (Data, Typeable, Show, Eq)  -data Configuration = Configuration {-    mHomePage       :: String,              -- ^ Startup page -    mSocketDir      :: String,              -- ^ Directory where 0MQ will be created ("/tmp" for example)-    mUIFile         :: String,              -- ^ Path to XML file describing UI (used by GtkBuilder)-    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+data Config = {-forall a.-} Config {+    mHomePage    :: String,                    -- ^ Startup page +    mSocketDir   :: String,                    -- ^ Directory where 0MQ will be created ("/tmp" for example)+    mUIFile      :: String,                    -- ^ Path to XML file describing UI (used by GtkBuilder)+    mKeys        :: Environment -> KeysList,   -- ^ List of keybindings+    mWebSettings :: [AttrOp WebSettings],      -- ^ WebSettings' attributes to use with webkit (see Webkit.WebSettings documentation)+    mSetup       :: Environment -> IO (),      -- ^ Custom startup instructions+    mCommands    :: CommandsList,              -- ^ Custom commands to use with IPC sockets+    mError       :: Maybe String               -- ^ Error+    --mCustom      :: a }  data GUI = GUI {@@ -46,13 +50,18 @@     mInspectorWindow    :: Window,          -- ^ WebInspector window     mScrollWindow       :: ScrolledWindow,  -- ^ ScrolledWindow containing the webview     mWebView            :: WebView,         -- ^ Browser's webview-    mPromptLabel        :: Label,           -- ^ Description of current prompt-    mPromptEntry        :: Entry,           -- ^ Prompt entry+    mPromptBar          :: PromptBar,      mStatusBox          :: HBox,            -- ^ Status bar's horizontal box     mBuilder            :: Builder          -- ^ Builder object created from XML file } +data PromptBar = PromptBar {+    mBox         :: HBox,+    mDescription :: Label, -- ^ Description of current prompt+    mEntry       :: Entry -- ^ Prompt entry+} + -- | List of bound keys -- All callbacks are fed with the Browser instance -- Note 1 : for modifiers, lists are used for convenience purposes,@@ -60,7 +69,7 @@ --          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-type KeysList = [(([Modifier], String), (Browser -> IO ()))]+type KeysList = [(([Modifier], String), IO ())] -type CommandsList = [(String, ([String] -> Socket Rep -> Browser -> IO ()))]-type CommandsMap  = Map String ([String] -> Socket Rep -> Browser -> IO ())+type CommandsList = [(String, ([String] -> Socket Rep -> Environment -> IO ()))]+type CommandsMap  = Map String ([String] -> Socket Rep -> Environment -> IO ())
Hbro/Util.hs view
@@ -3,8 +3,14 @@ -- {{{ Imports import Hbro.Types +--import Control.Monad.Reader+import Control.Monad++import Data.List import qualified Data.Map as Map import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Text.IO as T  import Graphics.UI.Gtk.Display.Label import Graphics.UI.Gtk.Gdk.EventM@@ -12,6 +18,9 @@ import Graphics.UI.Gtk.General.General  --import System.Console.CmdArgs (whenLoud, whenNormal)+import qualified System.Info as Sys+import System.IO+import System.Posix.Process import System.Process -- }}} @@ -47,13 +56,13 @@  -- | Convert key bindings list to a map. -- Calls importKeyBindings'.-importKeyBindings :: [(([Modifier], String), (Browser -> IO ()))] -> Map.Map (Set.Set Modifier, String) (Browser -> IO ()) +importKeyBindings :: KeysList -> Map.Map (Set.Set Modifier, String) (IO ()) importKeyBindings list = Map.fromList $ importKeyBindings' list  -- | Convert modifiers list to modifiers sets. -- The order of modifiers in key bindings don't matter. -- Called by importKeyBindings.-importKeyBindings' :: [(([Modifier], String), (Browser -> IO ()))] -> [((Set.Set Modifier, String), (Browser -> IO ()))]+importKeyBindings' :: KeysList -> [((Set.Set Modifier, String), IO ())] importKeyBindings' (((a, b), c):t) = ((Set.fromList a, b), c):(importKeyBindings' t) importKeyBindings' _ = [] -- }}}@@ -67,9 +76,12 @@ -- | 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`-spawn :: CreateProcess -> IO ()---spawn command = runCommand' $ "nohup " ++ command ++ " > /dev/null 2>&1"-spawn command = createProcess command { std_in = CreatePipe,  std_out = CreatePipe, std_err = CreatePipe, close_fds = True } >> return ()+spawn :: String -> [String] -> IO ()+spawn command options = spawn' (proc command options)++spawn' :: CreateProcess -> IO ()+--spawn' command = runCommand' $ "nohup " ++ command ++ " > /dev/null 2>&1"+spawn' command = createProcess command { std_in = CreatePipe,  std_out = CreatePipe, std_err = CreatePipe, close_fds = True } >> return () -- }}}  -- | Set a temporary markup text to a label that disappears after some delay.@@ -79,3 +91,31 @@     timeoutAdd clear delay   where     clear = labelSetMarkup label "" >> return False+++getAllProcessIDs :: IO [FilePath]+getAllProcessIDs = do +    (_, pids, _)  <- readProcessWithExitCode "pidof" ["hbro"] []+    (_, pids', _) <- readProcessWithExitCode "pidof" ["hbro-" ++ Sys.os ++ "-" ++ Sys.arch] []+    myPid         <- getProcessID++    return $ delete (show myPid) . nub . words $ pids ++ " " ++ pids'+    +    +++(>>?) :: (a -> IO ()) -> Maybe a -> IO ()+(>>?) = maybe (return ())++    +    +dmenu :: [String] -> T.Text -> IO String+dmenu options input = do+    (in_, out, err, pid) <- runInteractiveProcess "dmenu" options Nothing Nothing+    T.hPutStr in_ input+    hClose  in_+    +    output <- catch (hGetLine out) $ \_error -> return []+    +    hClose out >> hClose err >> (void $ waitForProcess pid)+    return output
examples/hbro.hs view
@@ -1,16 +1,17 @@ module Main where  -- {{{ Imports-import Hbro.Core hiding(goBack, goForward)+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 qualified Hbro.Extra.History as History import Hbro.Extra.Misc import Hbro.Extra.Prompt import Hbro.Extra.Session import Hbro.Extra.StatusBar import Hbro.Gui+import Hbro.Socket import Hbro.Types import Hbro.Util @@ -29,6 +30,7 @@ import Graphics.UI.Gtk.WebKit.WebView import Graphics.UI.Gtk.Windows.Window +import System.Directory import System.Environment import System.Glib.Attributes import System.Glib.Signals@@ -36,180 +38,198 @@ import System.Process  -- }}} -+-- | Main function, basically launches hbro. main :: IO () main = do-    configHome <- getEnv "XDG_CONFIG_HOME"+    home <- getHomeDirectory+    tmp  <- getTemporaryDirectory+    launchHbro $ myConfig home tmp -    -- See Hbro.Types.Configuration documentation for fields description-    -- Commented out fields indicate default values-    hbro defaultConfiguration {-        --mSocketDir    = "/tmp/",-        mUIFile         = configHome ++ "/hbro/ui.xml",-        --mHomePage     = "https://www.google.com",-        mKeys           = myKeys,-        mWebSettings    = myWebSettings,-        mSetup          = mySetup-    } +-- | Application parameters.+-- See Hbro.Types.Parameters documentation for fields description.+-- Commented out fields indicate default values.+myConfig :: String -> String -> Config+myConfig home tmp = (defaultConfig home tmp) {+    --mSocketDir = tmp,+    mUIFile      = home ++ "/.config/hbro/ui.xml",+    mHomePage    = "https://duckduckgo.com",+    mKeys        = myKeys home,+    mWebSettings = myWebSettings,+    mSetup       = mySetup+} ++myHistoryFile :: FilePath -> FilePath+myHistoryFile home = home ++ "/.config/hbro/history"++myBookmarksFile :: FilePath -> FilePath+myBookmarksFile home = home ++ "/.config/hbro/bookmarks"++ -- {{{ Keys -- Note that this example is suited for an azerty keyboard.-myKeys :: KeysList-myKeys = generalKeys ++ bookmarksKeys ++ historyKeys ++ sessionKeys--generalKeys :: KeysList-generalKeys = [+myKeys :: FilePath -> Environment -> KeysList+myKeys home environment@Environment {mGUI = gui, mConfig = config, mContext = context} = let+    window         = mWindow       gui+    webView        = mWebView      gui+    scrolledWindow = mScrollWindow gui+    statusBox      = mStatusBox    gui+    promptBar      = mPromptBar    gui+    promptEntry    = mEntry promptBar+    bookmarksFile  = myBookmarksFile home+    historyFile    = myHistoryFile   home+    socketDir      = mSocketDir config+  in  +    [ --  ((modifiers,        key),           callback) -- Browse-    (([Control],        "<Left>"),      goBack),-    (([Control],        "<Right>"),     goForward),-    (([Alt],            "<Left>"),      goBackList),-    (([Alt],            "<Right>"),     goForwardList),-    (([Control],        "s"),           stopLoading),-    (([],               "<F5>"),        reload True),-    (([Shift],          "<F5>"),        reload False),-    (([Control],        "r"),           reload True),-    (([Control, Shift], "R"),           reload False),-    (([Control],        "^"),           horizontalHome),-    (([Control],        "$"),           horizontalEnd),-    (([Control],        "<Home>"),      verticalHome),-    (([Control],        "<End>"),       verticalEnd),-    (([Alt],            "<Home>"),      goHome),-    (([Control],        "g"),           promptGoogle),+    (([Control],        "<Left>"),      webViewGoBack    webView),+    (([Control],        "<Right>"),     webViewGoForward webView),+    (([Alt],            "<Left>"),      (goBackList    webView ["-l", "10"]) >>= maybe (return ()) (loadURI webView)),+    (([Alt],            "<Right>"),     (goForwardList webView ["-l", "10"]) >>= maybe (return ()) (loadURI webView)),+    (([Control],        "s"),           webViewStopLoading       webView),+    (([],               "<F5>"),        webViewReload            webView),+    (([Control],        "<F5>"),        webViewReloadBypassCache webView),+    (([Control],        "^"),           goLeft   scrolledWindow),+    (([Control],        "$"),           goRight  scrolledWindow),+    (([Control],        "<Home>"),      goTop    scrolledWindow),+    (([Control],        "<End>"),       goBottom scrolledWindow),+    (([Alt],            "<Home>"),      goHome webView config),+    (([Control],        "g"),           prompt "Google search" "" (\words -> loadURI webView ("https://www.google.com/search?q=" ++ words)) promptBar),  -- Display-    (([Control, Shift], "+"),           zoomIn),-    (([Control],        "-"),           zoomOut),-    (([],               "<F11>"),       fullscreen),-    (([],               "<Escape>"),    unfullscreen),-    (([Control],        "b"),           toggleStatusBar),-    (([Control],        "u"),           toggleSourceMode),+    (([Control, Shift], "+"),           webViewZoomIn    webView),+    (([Control],        "-"),           webViewZoomOut   webView),+    (([],               "<F11>"),       windowFullscreen   window),+    (([],               "<Escape>"),    windowUnfullscreen window),+    (([Control],        "b"),           toggleVisibility statusBox),+    (([Control],        "u"),           toggleSourceMode webView),  -- Prompt-    (([Control],        "o"),           promptURL False), -    (([Control, Shift], "O"),           promptURL True),+    (([Control],        "o"),           prompt "Open URL " "" (loadURI webView) promptBar),+    (([Control, Shift], "O"),           webViewGetUri webView >>= maybe (return ()) (\uri -> prompt "Open URL " uri (loadURI webView) promptBar)),  -- Search-    (([Shift],          "/"),           promptFind False True True),-    (([Control],        "f"),           promptFind False True True),-    (([Shift],          "?"),           promptFind False False True),-    (([Control],        "n"),           findNext False True True),-    (([Control, Shift], "N"),           findNext False False True),+    (([Shift],          "/"),           promptIncremental "Search " "" (\word -> webViewSearchText webView word False True True >> return ()) promptBar),+    (([Control],        "f"),           promptIncremental "Search " "" (\word -> webViewSearchText webView word False True True >> return ()) promptBar),+    (([Shift],          "?"),           promptIncremental "Search " "" (\word -> webViewSearchText webView word False False True >> return ()) promptBar),+    (([Control],        "n"),           entryGetText promptEntry >>= \word -> webViewSearchText webView word False True True >> return ()),+    (([Control, Shift], "N"),           entryGetText promptEntry >>= \word -> webViewSearchText webView word False False True >> return ()),  -- Copy/paste-    (([Control],        "y"),           copyUri),-    (([Control, Shift], "Y"),           copyTitle),-    (([Control],        "p"),           loadURIFromClipboard),-    (([Control, Shift], "P"),           newInstanceFromClipboard),+    (([Control],        "y"),           webViewGetUri   webView >>= maybe (return ()) toClipboard),+    (([Control, Shift], "Y"),           webViewGetTitle webView >>= maybe (return ()) toClipboard),+    (([Control],        "p"),           withClipboard $ maybe (return ()) (loadURI webView)),+    (([Control, Shift], "P"),           withClipboard $ maybe (return ()) (\uri -> spawn "hbro" ["-u", uri])),  -- Others-    (([Control],        "i"),           showWebInspector),-    (([Alt],            "p"),           printPage),-    (([Control],        "t"),           \_ -> newInstance),-    (([Control],        "w"),           \_ -> mainQuit)-    ]--bookmarksKeys :: KeysList-bookmarksKeys = [-    (([Control],        "d"),           Bookmarks.addWithTags),-    (([Control, Shift], "D"),           Bookmarks.addAllWithTags),-    (([Alt],            "d"),           \_ -> Bookmarks.deleteWithTag),-    (([Control],        "l"),           Bookmarks.load),-    (([Control, Shift], "L"),           \_ -> Bookmarks.loadWithTag),-    (([Control],        "q"),           Queue.append),-    (([Alt],            "q"),           \b -> do-        uri <- Queue.popFront-        loadURI uri b)-    ]+    (([Control],        "i"),           showWebInspector webView),+    (([Alt],            "p"),           printPage        webView),+    (([Control],        "t"),           spawn "hbro" []),+    (([Control],        "w"),           mainQuit), -historyKeys :: KeysList-historyKeys = [-    (([Control],        "h"),           loadFromHistory)-    ]+-- Bookmarks+    (([Control],        "d"),           webViewGetUri webView >>= maybe (return ()) (\uri -> prompt "Bookmark with tags:" "" (\tags -> Bookmarks.add bookmarksFile uri (words tags)) promptBar)),+    (([Control, Shift], "D"),           prompt "Bookmark all instances with tag:" "" (\tags -> sendCommandToAll context socketDir "GET_URI" >>= mapM (\uri -> Bookmarks.add bookmarksFile uri $ words tags) >> (webViewGetUri webView) >>= maybe (return ()) (\uri -> Bookmarks.add bookmarksFile uri $ words tags) >> return ()) promptBar),+    (([Alt],            "d"),           Bookmarks.deleteWithTag bookmarksFile ["-l", "10"]),+    (([Control],        "l"),           Bookmarks.select        bookmarksFile ["-l", "10"] >>= maybe (return ()) (loadURI webView)),+    (([Control, Shift], "L"),           Bookmarks.selectTag     bookmarksFile ["-l", "10"] >>= maybe (return ()) (\uris -> mapM (\uri -> spawn "hbro" ["-u", uri]) uris >> return ())),+--    (([Control],        "q"),           webViewGetUri webView >>= maybe (return ()) (Queue.append),+--    (([Alt],            "q"),           \b -> do+--        uri <- Queue.popFront+--        loadURI uri b), -sessionKeys :: KeysList-sessionKeys = [-    (([Alt],            "l"),           loadFromSession)+-- History+    (([Control],        "h"),           History.select historyFile ["-l", "10"] >>= maybe (return ()) (loadURI webView))+    +-- Session+    --(([Alt],            "l"),           loadFromSession ["-l", "10"])     ] -- }}}  -- {{{ Web settings -- Commented lines correspond to default values-myWebSettings :: IO WebSettings-myWebSettings = do-    settings <- webSettingsNew-    set settings [-        --SETTING                                      DEFAULT VALUE -        --webSettingsCursiveFontFamily              := "serif",-        --webSettingsDefaultFontFamily              := "sans-serif",-        --webSettingsFantasyFontFamily              := ,-        --webSettingsMonospaceFontFamily            := "monospace",-        --webSettingsSansFontFamily                 := "sans-serif",-        --webSettingsSerifFontFamily                := "serif",-        --webSettingsDefaultFontSize                := ,-        --webSettingsDefaultMonospaceFontSize       := 10,-        --webSettingsMinimumFontSize                := 5,-        --webSettingsMinimumLogicalFontSize         := 5,-        --webSettingsAutoLoadImages                 := True,-        --webSettingsAutoShrinkImages               := True,-        --webSettingsDefaultEncoding                := "iso-8859-1",-        --webSettingsEditingBehavior                := EditingBehaviorWindows,-        --webSettingsEnableCaretBrowsing              := False,-        webSettingsEnableDeveloperExtras            := True,-        --webSettingsEnableHtml5Database              := True,-        --webSettingsEnableHtml5LocalStorage          := True,-        --webSettingsEnableOfflineWebApplicationCache := True,-        webSettingsEnablePlugins                    := True,-        webSettingsEnablePrivateBrowsing            := False, -- Experimental-        webSettingsEnableScripts                    := True,-        --webSettingsEnableSpellChecking              := False,-        webSettingsEnableUniversalAccessFromFileUris := True,-        webSettingsEnableXssAuditor                 := True,-        --webSettingsEnableSiteSpecificQuirks       := False,-        --webSettingsEnableDomPaste                 := False,-        --webSettingsEnableDefaultContextMenu       := True,-        webSettingsEnablePageCache                  := True,-        --webSettingsEnableSpatialNavigation        := False,-        --webSettingsEnforce96Dpi                   := ,-        webSettingsJSCanOpenWindowAuto              := True,-        --webSettingsPrintBackgrounds               := True,-        --webSettingsResizableTextAreas             := True,-        webSettingsSpellCheckingLang                := Just "en_US",-        --webSettingsTabKeyCyclesThroughElements    := True,-        webSettingsUserAgent                        := "Mozilla/5.0 (X11; Linux x86_64; rv:2.0.1) Gecko/20100101 Firefox/4.0.1"-        --webSettingsUserStylesheetUri              := Nothing,-        --webSettingsZoomStep                       := 0.1-        ]-    return settings+myWebSettings :: [AttrOp WebSettings]+myWebSettings = [+    --SETTING                                      DEFAULT VALUE +    --webSettingsCursiveFontFamily              := "serif",+    --webSettingsDefaultFontFamily              := "sans-serif",+    --webSettingsFantasyFontFamily              := ,+    --webSettingsMonospaceFontFamily            := "monospace",+    --webSettingsSansFontFamily                 := "sans-serif",+    --webSettingsSerifFontFamily                := "serif",+    --webSettingsDefaultFontSize                := ,+    --webSettingsDefaultMonospaceFontSize       := 10,+    --webSettingsMinimumFontSize                := 5,+    --webSettingsMinimumLogicalFontSize         := 5,+    --webSettingsAutoLoadImages                 := True,+    --webSettingsAutoShrinkImages               := True,+    --webSettingsDefaultEncoding                := "iso-8859-1",+    --webSettingsEditingBehavior                := EditingBehaviorWindows,+    --webSettingsEnableCaretBrowsing              := False,+    webSettingsEnableDeveloperExtras            := True,+    --webSettingsEnableHtml5Database              := True,+    --webSettingsEnableHtml5LocalStorage          := True,+    --webSettingsEnableOfflineWebApplicationCache := True,+    webSettingsEnablePlugins                    := True,+    webSettingsEnablePrivateBrowsing            := False, -- Experimental+    webSettingsEnableScripts                    := False,+    --webSettingsEnableSpellChecking              := False,+    webSettingsEnableUniversalAccessFromFileUris := True,+    webSettingsEnableXssAuditor                 := True,+    --webSettingsEnableSiteSpecificQuirks       := False,+    --webSettingsEnableDomPaste                 := False,+    --webSettingsEnableDefaultContextMenu       := True,+    webSettingsEnablePageCache                  := True,+    --webSettingsEnableSpatialNavigation        := False,+    --webSettingsEnforce96Dpi                   := ,+    webSettingsJSCanOpenWindowAuto              := True,+    --webSettingsPrintBackgrounds               := True,+    --webSettingsResizableTextAreas             := True,+    webSettingsSpellCheckingLang                := Just "en_US",+    --webSettingsTabKeyCyclesThroughElements    := True,+    webSettingsUserAgent                        := "Mozilla/5.0 (X11; Linux x86_64; rv:2.0.1) Gecko/20100101 Firefox/4.0.1"+    --webSettingsUserStylesheetUri              := Nothing,+    --webSettingsZoomStep                       := 0.1+    ] -- }}}  -- {{{ Setup-mySetup :: Browser -> IO ()-mySetup browser = +mySetup :: Environment -> IO ()+mySetup environment@Environment {mGUI = gui} =      let-        builder         = mBuilder      (mGUI browser)-        webView         = mWebView      (mGUI browser)-        scrollWindow    = mScrollWindow (mGUI browser)-        window          = mWindow       (mGUI browser)-    in do-    -- Default background (basically for status bar)-        widgetModifyBg window StateNormal (Color 0 0 10000)+        builder         = mBuilder      gui +        webView         = mWebView      gui+        scrolledWindow  = mScrollWindow gui+        window          = mWindow       gui+    in do        +    -- Scroll position in status bar+        scrollLabel <- builderGetObject builder castToLabel "scroll"+        setupScrollWidget scrollLabel scrolledWindow+    +    -- Zoom level in status bar+        zoomLabel <- builderGetObject builder castToLabel "zoom"+        statusBarZoomLevel zoomLabel webView         -    -- Status bar-        statusBarScrollPosition browser-        statusBarZoomLevel      browser-        statusBarPressedKeys    browser-        statusBarLoadProgress   browser-        statusBarURI            browser+    -- Pressed keys in status bar+        keysLabel <- builderGetObject builder castToLabel "keys"+        statusBarPressedKeys keysLabel webView+        +    -- Load progress in status bar+        progressLabel <- builderGetObject builder castToLabel "progress"+        statusBarLoadProgress progressLabel webView+        +    -- Current URI in status bar+        uriLabel <- builderGetObject builder castToLabel "uri"+        statusBarURI uriLabel webView      -- Session manager-        setupSession browser+        --setupSession browser          _ <- on webView titleChanged $ \_ title ->             set window [ windowTitle := ("hbro | " ++ title)] -     -- Download requests         _ <- on webView downloadRequested $ \download -> do             uri  <- downloadGetUri download@@ -232,16 +252,15 @@                 (True, _) -> webPolicyDecisionUse policyDecision >> return True                 _         -> webPolicyDecisionDownload policyDecision >> return True -     -- History handler+        home <- getHomeDirectory         _ <- on webView loadFinished $ \_ -> do             uri   <- webViewGetUri   webView             title <- webViewGetTitle webView             case (uri, title) of-                (Just uri', Just title') -> addToHistory uri' title'+                (Just uri', Just title') -> History.add (myHistoryFile home) uri' title'                 _ -> return () -     -- On navigating to a new URI     -- Return True to forbid navigation, False to allow         _ <- on webView navigationPolicyDecisionRequested $ \_ request action policyDecision -> do@@ -256,17 +275,16 @@                 Just uri ->                      case mouseButton of                         1 -> return False -- Left button -                        2 -> spawn (proc "hbro" ["-u", uri]) >> putStrLn uri >> return True -- Middle button+                        2 -> spawn "hbro" ["-u", uri] >> putStrLn uri >> return True -- Middle button                         3 -> return False -- Right button                         _ -> return False -- No mouse button pressed                 _        -> return False-                  -- On requesting new window         _ <- on webView newWindowPolicyDecisionRequested $ \_ request action policyDecision -> do             getUri <- networkRequestGetUri request             case getUri of-                Just uri -> (spawn $ proc "hbro" ["-u", uri]) >> putStrLn uri+                Just uri -> (spawn "hbro" ["-u", uri]) >> putStrLn uri                 _        -> putStrLn "ERROR: wrong URI given, unable to open window."              return True@@ -280,15 +298,7 @@      myDownload :: String -> String -> IO () myDownload uri name = do-    home <- getEnv "HOME"-    --spawn $ proc "wget [uri, "-O", home ++ "/" ++ name]-    --spawn $ proc "axel [uri, "-o", home ++ "/" ++ name]-    spawn $ proc "aria2c" [uri, "-d", home ++ "/", "-o", name]--promptGoogle :: Browser -> IO ()-promptGoogle browser = -    prompt "Google search" "" False browser (\browser' -> do-        keyWords <- entryGetText (mPromptEntry $ mGUI browser')-        loadURI ("https://www.google.com/search?q=" ++ keyWords) browser'-        return ())-+    home <- getHomeDirectory+    --spawn "wget [uri, "-O", home ++ "/" ++ name]+    --spawn "axel [uri, "-o", home ++ "/" ++ name]+    spawn "aria2c" [uri, "-d", home ++ "/", "-o", name]
hbro.cabal view
@@ -1,5 +1,5 @@ Name:                hbro-Version:             0.6.8.2+Version:             0.7.0.0 Synopsis:            A minimal KISS compliant browser -- Description:          Homepage:            http://projects.haskell.org/hbro/@@ -48,7 +48,6 @@         Hbro.Extra.Clipboard,         Hbro.Extra.History,         Hbro.Extra.Misc,-        Hbro.Extra.Prompt,         Hbro.Extra.Session,         Hbro.Extra.StatusBar,         Hbro.Gui,@@ -62,12 +61,8 @@     Build-depends:          hbro,         base == 4.*,-        glib,-        gtk,-        mtl,-        process,-        unix,-        webkit+        directory,+        mtl     Main-is: Main.hs     Hs-Source-Dirs: Hbro       Ghc-options: -Wall -threaded