hbro-contrib (empty) → 0.8.0.0
raw patch · 14 files changed
+1150/−0 lines, 14 filesdep +basedep +directorydep +filepathsetup-changed
Dependencies added: base, directory, filepath, glib, gtk, hbro, network, old-locale, pango, process, text, time, unix, webkit
Files
- Hbro/Bookmarks.hs +112/−0
- Hbro/BookmarksQueue.hs +81/−0
- Hbro/Clipboard.hs +17/−0
- Hbro/Download.hs +23/−0
- Hbro/History.hs +81/−0
- Hbro/Misc.hs +89/−0
- Hbro/Session.hs +60/−0
- Hbro/StatusBar.hs +186/−0
- LICENSE +13/−0
- README.rst +10/−0
- Setup.hs +2/−0
- examples/hbro.hs +323/−0
- examples/ui.xml +105/−0
- hbro-contrib.cabal +48/−0
+ Hbro/Bookmarks.hs view
@@ -0,0 +1,112 @@+module Hbro.Bookmarks (+ Entry(..),+ add,+ select,+ selectTag,+ deleteWithTag+) where++-- {{{ Imports+--import Hbro.Core+--import Hbro.Gui+--import Hbro.Types+import Hbro.Util++import Control.Exception+import Control.Monad hiding(forM_, mapM_)++--import qualified Data.ByteString.Char8 as B+import Data.Foldable hiding(find, foldr)+import Data.List+import Data.Maybe++import Network.URI++import Prelude hiding(catch, mapM_)++import System.IO+-- }}}++-- {{{ Type definitions+data Entry = Entry {+ mURI :: URI,+ mTags :: [String]+}+ +instance Show Entry where+ show (Entry uri tags) = unwords $ (show uri):tags+-- }}}++-- | Try to parse a String into a bookmark Entry.+parseEntry :: String -> Maybe Entry+parseEntry [] = Nothing+parseEntry line = return (words line) + >>= (\(h:t) -> parseURI h+ >>= (\uri -> listToMaybe t + >> (return $ Entry uri t)))++-- | Check if the given bookmark Entry is tagged with the given tag.+hasTag :: String -> Entry -> Bool+hasTag tag = isJust . (find $ (==) tag) . mTags++-- | Add a new entry to the bookmarks' database (which is a file).+add :: FilePath -- ^ Bookmarks' database file+ -> Entry -- ^ New bookmarks entry+ -> IO Bool+add bookmarksFile newEntry = do+ result <- try $ withFile bookmarksFile AppendMode (flip hPutStrLn (show newEntry))+ either (\e -> errorHandler bookmarksFile e >> return False) (const $ return True) result+ +-- | Open a dmenu with all (sorted alphabetically) bookmarks entries, and return the user's selection, if any.+select :: FilePath -- ^ Bookmarks' database file+ -> [String] -- ^ dmenu's commandline options+ -> IO (Maybe String)+select bookmarksFile dmenuOptions = do+ result <- try $ readFile bookmarksFile + + either (\e -> errorHandler bookmarksFile e >> return Nothing) (\x -> return $ Just x) result+ >>= (return . ((return . unlines . sort . nub . (map reformat) . lines) =<<))+ >>= (maybe (return Nothing) (dmenu dmenuOptions))+ >>= (return . ((return . last. words) =<<))++ +reformat :: String -> String+reformat line = unwords $ tags' ++ [uri]+ where+ uri:tags = words line + tags' = sort $ map (\tag -> '[':(tag ++ "]")) tags++-- | Open a dmenu with all (sorted alphabetically) bookmarks tags, and return the user's selection, if any.+selectTag :: FilePath -- ^ Bookmarks' database file+ -> [String] -- ^ dmenu's commandline options+ -> IO (Maybe [URI])+selectTag bookmarksFile dmenuOptions = do+ -- Read bookmarks file+ result <- try $ readFile bookmarksFile+ file <- either (\e -> errorHandler bookmarksFile e >> return Nothing) (\x -> return $ Just x) result+ + let entries = (return . catMaybes . (map parseEntry) . lines) =<< file+ let tags = (return . unlines . sort . nub . words . unwords . (foldr (union . mTags) [])) =<< entries++ -- Let user select a tag+ tag <- (maybe (return Nothing) (dmenu dmenuOptions) tags)+ return $ (return . (map mURI) . (\t -> filter (hasTag t) (maybe [] id entries))) =<< tag+++-- | Remove all bookmarks entries matching the given tag.+deleteWithTag :: FilePath -- ^ Bookmarks' database file+ -> [String] -- ^ dmenu's commandline options+ -> IO ()+deleteWithTag bookmarksFile dmenuOptions = do+ result <- try $ readFile bookmarksFile+ file <- either (\e -> errorHandler bookmarksFile e >> return Nothing) (\x -> return $ Just x) result+ + forM_ file $ \f -> do+ let entries = (catMaybes . (map parseEntry) . lines) f + let tags = (unlines . sort . nub . words . unwords . (foldr (union . mTags) [])) entries++ tag <- (dmenu dmenuOptions tags) + forM_ tag (\t -> do+ writeFile (bookmarksFile ++ ".old") $ unlines (map show entries)+ writeFile bookmarksFile $ (unlines . (map show) . (filter (not . (hasTag t)))) entries+ return ())
+ Hbro/BookmarksQueue.hs view
@@ -0,0 +1,81 @@+module Hbro.BookmarksQueue where++-- {{{ Imports+--import Hbro.Types++import Data.List+import qualified Data.Text as T+import qualified Data.Text.IO as T+-- }}}+++-- | Add current URI to the end of the queue.+--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 :: String -> String -> IO ()+push bookmarksFile uri = do+ file <- catch (T.readFile bookmarksFile) (\_error -> return T.empty)++ 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 :: String -> IO String+popFront bookmarksFile = do+ file <- catch (T.readFile bookmarksFile) (\_error -> return T.empty)++ if file == T.empty+ then return ""+ else do+ let fileLines = T.lines file+ let file' = T.unlines . tail . nub $ fileLines+ + T.writeFile (bookmarksFile ++ ".old") file+ T.writeFile bookmarksFile file'++ return $ T.unpack (head fileLines)++-- | Return the last URI from the queue, while removing it.+popBack :: String -> IO String+popBack bookmarksFile = do+ file <- catch (T.readFile bookmarksFile) (\_error -> return T.empty)++ if file == T.empty+ then return ""+ else do+ let fileLines = T.lines file+ let file' = T.unlines . reverse . tail . reverse. nub $ fileLines+ + T.writeFile (bookmarksFile ++ ".old") file+ T.writeFile bookmarksFile file'++ return $ T.unpack (head $ reverse fileLines)++-- | Return a random URI from the queue, while removing it.+-- popRandom :: Browser -> IO String+-- popRandom browser = do+-- configHome <- getEnv "XDG_CONFIG_HOME"+-- file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\e -> return T.empty)++-- if file == T.empty+-- then return ""+-- else do+-- let fileLines = T.lines file+-- let file' = T.unlines . reverse . tail . reverse. nub $ fileLines+-- +-- T.writeFile (configHome ++ "/hbro/queue.old") file+-- T.writeFile (configHome ++ "/hbro/queue") file'++-- return $ T.unpack (head $ reverse fileLines)+
+ Hbro/Clipboard.hs view
@@ -0,0 +1,17 @@+module Hbro.Clipboard where++-- {{{ Imports+--import Hbro.Core+--import Hbro.Types+--import Hbro.Util++import Graphics.UI.Gtk.General.Clipboard+-- }}}+++-- | Copy current URI in clipboard.+toClipboard :: String -> IO ()+toClipboard text = clipboardGet selectionPrimary >>= (`clipboardSetText` text)+ +withClipboard :: (Maybe String -> IO ()) -> IO ()+withClipboard callback = clipboardGet selectionPrimary >>= (`clipboardRequestText` callback)
+ Hbro/Download.hs view
@@ -0,0 +1,23 @@+module Hbro.Download where++-- {{{ Imports+import Hbro.Types+import Hbro.Util++import Graphics.UI.Gtk.Builder+import Graphics.UI.Gtk.Display.Label++import Network.URI++import System.FilePath+-- }}}++labelNotify :: Environment -> IO ()+labelNotify env = do+ feedbackLabel <- builderGetObject ((mBuilder . mGUI) env) castToLabel "feedback"+ labelSetMarkupTemporary feedbackLabel "<span foreground=\"green\">Download started</span>" 5000+ +aria, wget, axel :: URI -> FilePath -> String -> IO ()+aria uri directory filename = spawn "aria2c" [show uri, "-d", directory, "-o", filename]+wget uri directory filename = spawn "wget" [show uri, "-O", directory </> filename]+axel uri directory filename = spawn "axel" [show uri, "-o", directory </> filename]
+ Hbro/History.hs view
@@ -0,0 +1,81 @@+module Hbro.History (+ Entry(..),+ add,+ parseEntry,+ select+) where++-- {{{ Imports+--import Hbro.Core+--import Hbro.Types+import Hbro.Util++import Control.Exception+--import Control.Monad.Reader++import Data.List+import Data.Time.Format+import Data.Time.LocalTime++import Network.URI++--import System.IO.Error+import System.IO+import System.Locale+-- }}} ++-- {{{ Type definitions+data Entry = Entry {+ mTime :: LocalTime,+ mURI :: URI, + mTitle :: String+}++instance Show Entry where+ show (Entry time uri title) = unwords [(formatTime defaultTimeLocale dateFormat time), show uri, title]++dateFormat :: String+dateFormat = "%F %T"+-- }}}++-- | Add a new entry to history's database+add :: FilePath -- ^ Path to history file+ -> Entry -- ^ History entry to add+ -> IO Bool+add historyFile newEntry = do+ result <- try $ withFile historyFile AppendMode (`hPutStrLn` show newEntry)+ either (\e -> errorHandler historyFile e >> return False) (const $ return True) result ++-- | Try to parse a String into a history Entry.+parseEntry :: String -> Maybe Entry+parseEntry [] = Nothing+parseEntry line = (parseEntry' . words) line++parseEntry' :: [String] -> Maybe Entry+parseEntry' (d:t:u:t') = do+ time <- parseTime defaultTimeLocale dateFormat (unwords [d, t])+ uri <- parseURI u+ + return $ Entry time uri (unwords t')+parseEntry' _ = Nothing++-- | Open a dmenu with all (sorted alphabetically) history entries, and return the user's selection, if any+select :: FilePath -- ^ Path to history file+ -> [String] -- ^ dmenu's commandline options+ -> IO (Maybe Entry) -- ^ Selected history entry, if any+select historyFile dmenuOptions = do+ result <- try $ readFile historyFile+ + either (\e -> errorHandler historyFile e >> return Nothing) (return . return) result+ >>= (return . ((return . unlines . reverse . sort . nub . lines) =<<))+ >>= (maybe (return Nothing) (dmenu dmenuOptions))+ >>= (return . (parseEntry =<<))+++reformat :: String -> String+reformat line = + let+ _date:_time:uri:title = words line + in + unwords $ [uri] ++ title+
+ Hbro/Misc.hs view
@@ -0,0 +1,89 @@+module Hbro.Misc where++-- {{{ Imports+--import Hbro.Core+--import Hbro.Types+import Hbro.Util++import Data.Maybe++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 Network.URI++import System.IO+-- }}}+++-- | Same as goBack function from Hbro.Core,+-- but with feedback in case of failure.+--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 :: WebView -> [String] -> IO (Maybe URI)+goBackList webView dmenuOptions = do+ list <- webViewGetBackForwardList webView+ n <- webBackForwardListGetBackLength list+ backList <- webBackForwardListGetBackListWithLimit list n+ dmenuList <- mapM itemToEntry backList+ + (>>= (parseURIReference . head . words)) `fmap` (dmenu dmenuOptions $ (unlines . catMaybes) dmenuList)+ ++-- | List succeeding URIs in dmenu and let the user select which one to load.+goForwardList :: WebView -> [String] -> IO (Maybe URI)+goForwardList webView dmenuOptions = do+ list <- webViewGetBackForwardList webView+ n <- webBackForwardListGetForwardLength list+ forwardList <- webBackForwardListGetForwardListWithLimit list n+ dmenuList <- mapM itemToEntry forwardList+ + (>>= (parseURIReference . head . words)) `fmap` (dmenu dmenuOptions $ (unlines . catMaybes) dmenuList)+++itemToEntry :: WebHistoryItem -> IO (Maybe String)+itemToEntry item = do+ title <- webHistoryItemGetTitle item+ uri <- webHistoryItemGetUri item+ case uri of+ Just u -> return $ Just (u ++ " | " ++ (maybe "Untitled" id title))+ _ -> return Nothing+++-- | Toggle source display.+-- Current implementation forces a refresh of current web page, which may be undesired.+toggleSourceMode :: WebView -> IO ()+toggleSourceMode webView = do+ currentMode <- webViewGetViewSourceMode webView+ webViewSetViewSourceMode webView (not currentMode)+ webViewReload webView
+ Hbro/Session.hs view
@@ -0,0 +1,60 @@+module Hbro.Session where++-- {{{ Imports+--import Hbro.Types+import Hbro.Util++import Data.Foldable+import qualified Data.Text as T+import qualified Data.Text.IO as T++import Graphics.UI.Gtk.General.General+import Graphics.UI.Gtk.WebKit.WebView hiding(webViewGetUri)++import Prelude hiding(mapM_)++import System.Directory+import System.Environment+import System.Glib.Signals+import System.IO+import System.Posix.Process+import System.Process +-- }}}++setupSession :: WebView -> String -> IO ()+setupSession webView sessionDirectory = do+ pid <- getProcessID+ previousSession <- getDirectoryContents sessionDirectory++ let sessionFile = sessionDirectory ++ show pid++ _ <- on webView loadFinished $ \_ -> do+ webViewGetUri webView >>= mapM_ ((writeFile sessionFile) . show)+ + _ <- quitAdd 0 $ do+ removeFile sessionFile+ return False+ + return ()+++--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/StatusBar.hs view
@@ -0,0 +1,186 @@+module Hbro.StatusBar where++-- {{{ Imports+--import Hbro.Keys+import Hbro.Types+--import Hbro.Util ++import Control.Monad hiding(forM_, mapM_)++import Data.Foldable+import Data.List+import Data.Maybe++import Graphics.Rendering.Pango.Enums+import Graphics.Rendering.Pango.Layout++import Graphics.UI.Gtk.Display.Label+import Graphics.UI.Gtk.Gdk.EventM+import Graphics.UI.Gtk.Misc.Adjustment+import Graphics.UI.Gtk.Scrolling.ScrolledWindow+import Graphics.UI.Gtk.WebKit.WebView++import Network.URI++import Prelude hiding(mapM_)++import System.Glib.Signals+-- }}}+++-- | 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+ lower <- adjustmentGetLower adjustment+ upper <- adjustmentGetUpper adjustment+ page <- adjustmentGetPageSize adjustment+ + case upper-lower-page of+ 0 -> labelSetText widget "ALL"+ x -> labelSetText widget $ show (round $ current/x*100) ++ "%"++ labelSetText widget "0%"+++-- | /!\ Doesn't work for now.+-- Write current zoom level in the given Label.+statusBarZoomLevel :: Label -> WebView -> IO ()+statusBarZoomLevel widget webView = do+ zoomLevel <- webViewGetZoomLevel webView+ + labelSetMarkup widget $ "<span foreground=\"white\">x" ++ escapeMarkup (show zoomLevel) ++ "</span>"+ ++-- | +withFeedback :: Label -> KeyEventCallback -> [Modifier] -> String -> IO Bool+withFeedback widget callback modifiers keys = do +-- Trigger callback+ result <- callback modifiers keys+ +-- Set color depending on result+ let color = case result of+ True -> Color 0 65535 0+ _ -> Color 65535 0 0+ + labelSetAttributes widget [+ AttrForeground {paStart = 0, paEnd = -1, paColor = color}+ ]+ +-- Write keystrokes state to label+ case (modifiers, isSuffixOf "<Escape>" keys) of+ (_ , True) -> labelSetText widget []+ ([], _) -> labelSetText widget keys+ (_, _) -> labelSetText widget (show modifiers ++ keys)+ + return result+ ++-- | Write current load progress in the given Label.+statusBarLoadProgress :: Label -> WebView -> IO ()+statusBarLoadProgress widget webView = do+-- Load started+ _ <- on webView loadStarted $ \_ -> do+ labelSetAttributes widget [+ AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0}+ ]+ labelSetText widget "0%"+-- Progress changed + _ <- on webView progressChanged $ \progress' -> do+ labelSetAttributes widget [+ AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 65535 0}+ ]+ labelSetText widget $ show progress' ++ "%"+-- Load finished+ _ <- on webView loadFinished $ \_ -> do+ labelSetAttributes widget [+ AttrForeground {paStart = 0, paEnd = -1, paColor = Color 0 65535 0}+ ]+ labelSetText widget "100%"+-- Error+ _ <- on webView loadError $ \_ _ _ -> do+ labelSetAttributes widget [+ AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0}+ ]+ labelSetText widget "ERROR"+ return False+ + return ()+++-- | Write current URI, or the destination of a hovered link, in the given Label.+setupURIWidget :: URIColors -> URIColors -> Label -> WebView -> IO ()+setupURIWidget normalColors secureColors widget webView = do+-- URI changed+ _ <- on webView loadCommitted $ \_ ->+ (mapM_ (labelSetURI normalColors secureColors widget)) =<< ((>>= parseURIReference) `fmap` (webViewGetUri webView))+ +-- Link (un)hovered+ _ <- on webView hoveringOverLink $ \_title hoveredURI -> do+ uri <- webViewGetUri webView+ + forM_ (hoveredURI >>= parseURIReference) $ labelSetURI normalColors secureColors widget+ unless (isJust hoveredURI) $ forM_ (uri >>= parseURIReference) (labelSetURI normalColors secureColors widget)+ + return ()+++-- | +labelSetURI :: URIColors -> URIColors -> Label -> URI -> IO ()+labelSetURI normalColors secureColors widget uri = do+ let colors = case uriScheme uri of+ "https:" -> secureColors+ _ -> normalColors+ + let i:j:k:l:_ = map length [+ uriScheme uri,+ maybe "" uriRegName (uriAuthority uri),+ uriPath uri,+ uriQuery uri+ ]+ + labelSetAttributes widget $ [+ AttrWeight{ paStart = 0, paEnd = -1, paWeight = WeightBold },+ AttrForeground{ paStart = 0, paEnd = i+2, paColor = mScheme colors },+ AttrForeground{ paStart = i+2, paEnd = i+2+j, paColor = mHost colors },+ AttrForeground{ paStart = i+2+j, paEnd = i+2+j+k, paColor = mPath colors },+ AttrForeground{ paStart = i+2+j+k, paEnd = i+2+j+k+l, paColor = mQuery colors },+ AttrForeground{ paStart = i+2+j+k+l, paEnd = -1, paColor = mFragment colors }+ ]+ + labelSetText widget (show uri)+ + +data URIColors = URIColors {+ mScheme :: Color,+ mHost :: Color,+ mPort :: Color,+ mUser :: Color,+ mPath :: Color,+ mQuery :: Color,+ mFragment :: Color+}++defaultURIColors :: URIColors+defaultURIColors = URIColors {+ mScheme = Color 20000 20000 20000,+ mHost = Color 50000 50000 50000,+ mPort = Color 65535 0 0,+ mUser = Color 0 65535 0,+ mPath = Color 0 65535 65535,+ mQuery = Color 20000 20000 20000,+ mFragment = Color 10000 10000 65535+}+++defaultSecureURIColors :: URIColors+defaultSecureURIColors = defaultURIColors {+ mHost = Color 50000 50000 0+}
+ LICENSE view
@@ -0,0 +1,13 @@+DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE+Version 2, December 2004++Copyright (C) 2011 koral <koral at mailoo dot org>++Everyone is permitted to copy and distribute verbatim or modified+copies of this license document, and changing it is allowed as long+as the name is changed.++DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE+TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++0. You just DO WHAT THE FUCK YOU WANT TO.
+ README.rst view
@@ -0,0 +1,10 @@+============+hbro-contrib+============++This package gathers third-party extensions to *hbro_*.++Informations about versions, dependencies, source repositories and contacts can be found in hackage_.+++.. _hbro: http://hackage.haskell.org/package/hbro
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/hbro.hs view
@@ -0,0 +1,323 @@+{-# LANGUAGE DoRec #-}+module Main where++-- {{{ Imports+import qualified Hbro.Bookmarks as Bookmarks+import qualified Hbro.BookmarksQueue as Queue+import Hbro.Clipboard+import Hbro.Core+import qualified Hbro.Download as Download+import Hbro.Gui+import Hbro.Hbro+import qualified Hbro.History as History+import Hbro.Keys+import Hbro.Misc+import Hbro.Session+import Hbro.Socket+import Hbro.StatusBar+import Hbro.Types+import Hbro.Util++import Control.Monad hiding(forM_, mapM_)++import Data.Foldable+import Data.Time++import Graphics.UI.Gtk.Abstract.Widget+import Graphics.UI.Gtk.Builder+import Graphics.UI.Gtk.Display.Label+import Graphics.UI.Gtk.Entry.Entry+import Graphics.UI.Gtk.Gdk.EventM+import Graphics.UI.Gtk.Gdk.GC+import Graphics.UI.Gtk.General.General+import Graphics.UI.Gtk.WebKit.Download+import Graphics.UI.Gtk.WebKit.NetworkRequest+import Graphics.UI.Gtk.WebKit.WebNavigationAction+import Graphics.UI.Gtk.WebKit.WebPolicyDecision+import Graphics.UI.Gtk.WebKit.WebSettings+import Graphics.UI.Gtk.WebKit.WebView hiding(webViewGetUri, webViewLoadUri)+import Graphics.UI.Gtk.Windows.Window++import Network.URI++import Prelude hiding(mapM_)++import System.Directory+import System.Environment+import System.Environment.XDG.BaseDir+import System.FilePath+import System.Glib.Attributes+import System.Glib.Signals+-- import System.Posix.Process+import System.Process +-- }}}++-- Main function, expected to call launchHbro.+-- You can add custom tasks before & after calling it.+main :: IO ()+main = launchHbro myConfig++-- A structure containing your configuration settings, overriding+-- fields in the default config. Any you don't override will +-- use the defaults defined in Hbro.Types.Parameters.+myConfig :: CommonDirectories -> Config+myConfig directories = (defaultConfig directories) {+ mSocketDir = mySocketDirectory directories,+ mUIFile = myUIFile directories,+ mKeyEventHandler = myKeyEventHandler,+ mKeyEventCallback = myKeyEventCallback,+ mHomePage = myHomePage,+ mWebSettings = myWebSettings,+ mSetup = mySetup,+ mDownloadHook = myDownloadHook+}++-- Various constant parameters+myHomePage = "https://duckduckgo.com"++mySocketDirectory, myUIFile, myHistoryFile, myBookmarksFile :: CommonDirectories -> FilePath+mySocketDirectory = mTemporary+myUIFile directories = (mConfiguration directories) </> "ui.xml"+myHistoryFile directories = (mData directories) </> "history"+myBookmarksFile directories = (mData directories) </> "bookmarks"++-- How to download files+myDownloadHook :: Environment -> URI -> String -> Int -> IO ()+myDownloadHook env uri filename _size = do+ Download.labelNotify env+ home <- getHomeDirectory + Download.aria uri home filename++-- How to handle keystrokes+myKeyEventHandler :: KeyEventCallback -> ConnectId WebView -> WebView -> EventM EKey Bool+myKeyEventHandler = advancedKeyEventHandler++myKeyEventCallback :: Environment -> KeyEventCallback+myKeyEventCallback environment@Environment{ mGUI = gui } modifiers keys = do+ keysLabel <- builderGetObject (mBuilder gui) castToLabel "keys"+ withFeedback keysLabel (simpleKeyEventCallback $ keysListToMap (myKeys environment)) modifiers keys+++-- {{{ Keys+-- Note that this example is suited for an azerty keyboard.+myKeys :: Environment -> KeysList+myKeys environment@Environment{ mGUI = gui, mConfig = config, mContext = context } = let+ window = mWindow gui+ webView = mWebView gui+ scrolledWindow = mScrollWindow gui+ statusBox = mStatusBar gui+ promptBar = mPromptBar gui+ promptEntry = mEntry promptBar+ bookmarksFile = myBookmarksFile (mCommonDirectories config)+ historyFile = myHistoryFile (mCommonDirectories config)+ socketDir = mSocketDir config+ in + [+-- ((modifiers, key), callback)+-- Browse+ (([Control], "<Left>"), webViewGoBack webView),+ (([Control], "<Right>"), webViewGoForward webView),+ (([Alt], "<Left>"), (goBackList webView ["-l", "10"]) >>= mapM_ (webViewLoadUri webView)),+ (([Alt], "<Right>"), (goForwardList webView ["-l", "10"]) >>= mapM_ (webViewLoadUri 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 -> forM_ (parseURIReference ("https://www.google.com/search?q=" ++ words)) (webViewLoadUri webView)) gui),++-- Display+ (([Control, Shift], "+"), webViewZoomIn webView),+ (([Control], "-"), webViewZoomOut webView),+ (([], "<F11>"), windowFullscreen window),+ (([], "<Escape>"), windowUnfullscreen window),+ (([Control], "b"), toggleVisibility statusBox),+ (([Control], "u"), toggleSourceMode webView),++-- Prompt+ (([Control], "o"), prompt "Open URL " [] ((mapM_ (webViewLoadUri webView)) . parseURIReference) gui),+ (([Control, Shift], "O"), webViewGetUri webView >>= mapM_ (\uri -> prompt "Open URL " (show uri) ((mapM_ (webViewLoadUri webView)) . parseURIReference) gui)),++-- Search+ (([Shift], "/"), promptIncremental "Search " [] (\word -> webViewSearchText webView word False True True >> return ()) gui),+ (([Control], "f"), promptIncremental "Search " [] (\word -> webViewSearchText webView word False True True >> return ()) gui),+ (([Shift], "?"), promptIncremental "Search " [] (\word -> webViewSearchText webView word False False True >> return ()) gui),+ (([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"), webViewGetUri webView >>= mapM_ (toClipboard . show)),+ (([Control, Shift], "Y"), webViewGetTitle webView >>= mapM_ toClipboard),+ (([Control], "p"), withClipboard $ maybe (return ()) ((mapM_ (webViewLoadUri webView)) . parseURIReference)),+ (([Control, Shift], "P"), withClipboard $ maybe (return ()) (\uri -> spawn "hbro" ["-u", uri])),++-- Misc+ (([], "<Escape>"), widgetHide $ mBox promptBar),+ (([Control], "i"), showWebInspector webView),+ (([Alt], "p"), printPage webView),+ (([Control], "t"), spawn "hbro" []),+ (([Control], "w"), mainQuit),++-- Bookmarks+ (([Control], "d"), webViewGetUri webView >>= mapM_ (\uri -> + prompt "Bookmark with tags:" "" (\tags -> void $+ Bookmarks.add bookmarksFile (Bookmarks.Entry uri (words tags))) + gui)),+ (([Control, Shift], "D"), prompt "Bookmark all instances with tag:" "" (\tags -> + ((map parseURI) `fmap` (sendCommandToAll context socketDir "GET_URI"))+ >>= mapM (mapM_ $ \uri -> Bookmarks.add bookmarksFile $ Bookmarks.Entry uri (words tags)) + >> (webViewGetUri webView) >>= mapM_ (\uri -> Bookmarks.add bookmarksFile $ Bookmarks.Entry uri (words tags))) + gui),+ (([Alt], "d"), Bookmarks.deleteWithTag bookmarksFile ["-l", "10"]),+ (([Control], "l"), Bookmarks.select bookmarksFile ["-l", "10"] >>= mapM_ ((mapM_ (webViewLoadUri webView)) . parseURIReference)),+ (([Control, Shift], "L"), Bookmarks.selectTag bookmarksFile ["-l", "10"] >>= mapM_ (\uris -> mapM (\uri -> spawn "hbro" ["-u", (show uri)]) uris >> return ())),+-- (([Control], "q"), webViewGetUri webView >>= maybe (return ()) (Queue.append),+-- (([Alt], "q"), \b -> do+-- uri <- Queue.popFront+-- loadURI uri b),++-- History+ (([Control], "h"), History.select historyFile ["-l", "10"] >>= mapM_ ((webViewLoadUri webView) . History.mURI))+ +-- Session+ --(([Alt], "l"), loadFromSession ["-l", "10"])+ ]+-- }}}++-- {{{ Web settings+-- Commented out lines correspond to default values.+myWebSettings :: [AttrOp WebSettings]+myWebSettings = [+-- SETTING 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 :: Environment -> IO ()+mySetup environment@Environment{ mGUI = gui, mConfig = config } = + let+ builder = mBuilder gui + webView = mWebView gui+ scrolledWindow = mScrollWindow gui+ window = mWindow gui+ directories = mCommonDirectories config+ historyFile = myHistoryFile directories+ getLabel = builderGetObject builder castToLabel+ in do+ -- Scroll position in status bar+ scrollLabel <- getLabel "scroll"+ setupScrollWidget scrollLabel scrolledWindow+ + -- Zoom level in status bar+ zoomLabel <- getLabel "zoom"+ statusBarZoomLevel zoomLabel webView+ + -- Load progress in status bar+ progressLabel <- getLabel "progress"+ statusBarLoadProgress progressLabel webView+ + -- Current URI in status bar+ uriLabel <- getLabel "uri"+ setupURIWidget defaultURIColors defaultSecureURIColors uriLabel webView+ + -- Session manager+ --setupSession browser++ -- + _ <- on webView titleChanged $ \_ title ->+ set window [ windowTitle := ("hbro | " ++ title)]++ -- Per MIME actions+ _ <- on webView mimeTypePolicyDecisionRequested $ \_ request mimetype policyDecision -> do+ show <- webViewCanShowMimeType webView mimetype++ case (show, mimetype) of+ (True, _) -> webPolicyDecisionUse policyDecision >> return True+ _ -> webPolicyDecisionDownload policyDecision >> return True++ -- History handler+ _ <- on webView loadFinished $ \_ -> do+ uri <- webViewGetUri webView+ title <- webViewGetTitle webView+ timeZone <- getCurrentTimeZone+ now <- (utcToLocalTime timeZone) `fmap` getCurrentTime+ + case (uri, title) of+ (Just u, Just t) -> History.add historyFile (History.Entry now u t) >> return ()+ _ -> return ()++ -- On navigating to a new URI+ -- Return True to forbid navigation, False to allow+ _ <- on webView navigationPolicyDecisionRequested $ \_ request action policyDecision -> do+ getUri <- networkRequestGetUri request+ reason <- webNavigationActionGetReason action+ mouseButton <- webNavigationActionGetButton action++ case getUri of+ Just ('m':'a':'i':'l':'t':'o':':':address) -> do+ putStrLn $ "Mailing to: " ++ address+ return True+ Just uri -> + case mouseButton of+ 1 -> return False -- Left button + 2 -> 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 "hbro" ["-u", uri]) >> putStrLn uri+ _ -> putStrLn "ERROR: wrong URI given, unable to open window."++ return True++ -- Favicon+ --_ <- on webView iconLoaded $ \uri -> do something++ return ()+-- }}}
+ examples/ui.xml view
@@ -0,0 +1,105 @@+<interface>+ <object class="GtkWindow" id="mainWindow">+ <child><object class="GtkVBox" id="windowBox">+ <property name="homogeneous">False</property>+ <property name="spacing">0</property>++ <!-- Scrolled window, will contain the webview -->+ <child>+ <object class="GtkScrolledWindow" id="webViewParent"></object>+ </child>+ ++ <!-- Prompt bar -->+ <child>+ <object class="GtkHBox" id="promptBox">+ <property name="homogeneous">False</property>+ <property name="spacing">10</property>+ + <child>+ <object class="GtkLabel" id="promptDescription"></object>+ <packing>+ <property name="fill">False</property>+ <property name="expand">False</property>+ </packing>+ </child>++ <child><object class="GtkEntry" id="promptEntry"></object></child>+ </object>++ <packing>+ <property name="fill">False</property>+ <property name="expand">False</property>+ </packing>+ </child>+++ <!-- Status bar -->+ <child>+ <object class="GtkHBox" id="statusBox">+ <property name="homogeneous">False</property>+ <property name="spacing">5</property>+ + <child>+ <object class="GtkLabel" id="progress"></object>+ <packing>+ <property name="fill">False</property>+ <property name="expand">False</property>+ </packing>+ </child>++ <child>+ <object class="GtkLabel" id="uri">+ <property name="ellipsize">PANGO_ELLIPSIZE_END</property>+ <property name="xalign">0</property>+ <property name="yalign">0</property>+ </object>+ </child>++ <child>+ <object class="GtkLabel" id="scroll"></object>+ <packing>+ <property name="pack-type">GTK_PACK_END</property>+ <property name="fill">False</property>+ <property name="expand">False</property>+ </packing>+ </child>++ <child>+ <object class="GtkLabel" id="zoom"></object>+ <packing>+ <property name="pack-type">GTK_PACK_END</property>+ <property name="fill">False</property>+ <property name="expand">False</property>+ </packing>+ </child>++ <child>+ <object class="GtkLabel" id="keys"></object>+ <packing>+ <property name="pack-type">GTK_PACK_END</property>+ <property name="fill">False</property>+ <property name="expand">False</property>+ </packing>+ </child>++ <child>+ <object class="GtkLabel" id="feedback"></object>+ <packing>+ <property name="pack-type">GTK_PACK_END</property>+ <property name="fill">False</property>+ <property name="expand">False</property>+ </packing>+ </child>+ + </object>++ <packing>+ <property name="fill">False</property>+ <property name="expand">False</property>+ </packing>+ </child>++ </object></child>+ </object>+</interface>
+ hbro-contrib.cabal view
@@ -0,0 +1,48 @@+Name: hbro-contrib+Version: 0.8.0.0+Synopsis: Third-party extensions to hbro.+-- Description: +Homepage: http://projects.haskell.org/hbro-contrib/+Category: Browser,Web++License: OtherLicense+License-file: LICENSE+-- Copyright: +Author: koral+Maintainer: koral at mailoo dot org++Cabal-version: >=1.8+Build-type: Simple+Extra-source-files: README.rst examples/hbro.hs+Data-files: examples/ui.xml++Source-repository head+ Type: git+ Location: git@github.com:k0ral/hbro-contrib.git++Library+ Build-depends:+ base == 4.*,+ directory,+ filepath,+ glib,+ gtk,+ hbro,+ network,+ old-locale,+ pango,+ process,+ text,+ time,+ unix,+ webkit+ Exposed-modules:+ Hbro.Bookmarks,+ Hbro.BookmarksQueue,+ Hbro.Clipboard,+ Hbro.Download,+ Hbro.History,+ Hbro.Misc,+ Hbro.Session,+ Hbro.StatusBar+ Ghc-options: -Wall