hbro-contrib-1.1.1.0/0000755000000000000000000000000012101326015012415 5ustar0000000000000000hbro-contrib-1.1.1.0/LICENSE0000644000000000000000000000066012101326015013424 0ustar0000000000000000DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE Version 2, December 2004 Copyright (C) 2011 koral 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. hbro-contrib-1.1.1.0/hbro-contrib.cabal0000644000000000000000000000251712101326015015776 0ustar0000000000000000Name: hbro-contrib Version: 1.1.1.0 Synopsis: Third-party extensions to hbro. -- Description: Homepage: https://github.com/k0ral/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 >= 0.12.3, hbro >= 1.1.1.0, monad-control, mtl, network, old-locale, pango, process, -- random-extras, -- random-fu, text, time, transformers-base, unix, webkit Exposed-modules: Hbro.Bookmarks, Hbro.Download, Hbro.History, Hbro.Misc, Hbro.Settings, Hbro.StatusBar Extensions: ConstraintKinds, FlexibleContexts, FunctionalDependencies, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes Ghc-options: -Wall hbro-contrib-1.1.1.0/README.rst0000644000000000000000000000047312101326015014110 0ustar0000000000000000============ hbro-contrib ============ This package gathers third-party extensions for * hbro_ *. Informations about versions, dependencies, source repositories and contacts can be found in hackage_. .. _hbro: http://hackage.haskell.org/package/hbro .. _hackage: http://hackage.haskell.org/package/hbro-contrib hbro-contrib-1.1.1.0/Setup.hs0000644000000000000000000000005612101326015014052 0ustar0000000000000000import Distribution.Simple main = defaultMain hbro-contrib-1.1.1.0/examples/0000755000000000000000000000000012101326015014233 5ustar0000000000000000hbro-contrib-1.1.1.0/examples/ui.xml0000644000000000000000000001163212101326015015375 0ustar0000000000000000 False 0 False 10 False False False False False 5 False False PANGO_ELLIPSIZE_END 0 0 GTK_PACK_END False False GTK_PACK_END False False GTK_PACK_END False False GTK_PACK_END False False False False False 5 True 0 False False hbro-contrib-1.1.1.0/examples/hbro.hs0000644000000000000000000001103012101326015015514 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module Main where -- {{{ Imports import Hbro import qualified Hbro.Bookmarks as Bookmarks import qualified Hbro.Clipboard as Clipboard import qualified Hbro.Download as Download import qualified Hbro.Gui as GUI import qualified Hbro.History as History import Hbro.Keys as Key import Hbro.Misc import Hbro.Network import Hbro.Notification import qualified Hbro.Prompt as Prompt -- import Hbro.Session import Hbro.Settings import Hbro.StatusBar import qualified Hbro.Webkit.WebSettings as WS import Control.Conditional import Control.Lens hiding((??)) import Control.Monad hiding(forM_, mapM_) import Graphics.UI.Gtk.Display.Label import Graphics.UI.Gtk.WebKit.WebSettings import Network.URI hiding(parseURI, parseURIReference) import Prelude hiding(mapM_) import System.Directory import System.Environment.XDG.BaseDir import System.FilePath -- }}} myHomePage = URI "http:" (Just $ URIAuth "" "//www.google.com" "") "" "" "" -- Seriously ? -- Download to $HOME myDownloadHook :: URI -> String -> Int -> K () myDownloadHook uri filename _size = do destination <- io getHomeDirectory Download.aria destination uri filename myLoadFinishedHook :: K () myLoadFinishedHook = History.log =<< getUserDataDir "hbro" >/> "history" -- Setup (run at start-up) -- Note that keybindings are suited for an azerty keyboard. mySetup :: K () mySetup = do myHistoryFile <- getUserDataDir "hbro" >/> "history" myBookmarksFile <- getUserDataDir "hbro" >/> "bookmarks" -- Browse bind Key.Normal "C-" $ goBackList ["-l", "10"] >>= load bind Key.Normal "C-" $ goForwardList ["-l", "10"] >>= load bind Key.Normal "C-g" $ Prompt.read "DuckDuckGo search" "" (load <=< parseURIReference . ("http://duckduckgo.com/html?q=" ++) . escapeURIString isAllowedInURI) -- Bookmarks bind Key.Normal "C-d" $ Prompt.read "Bookmark with tags:" "" $ Bookmarks.add myBookmarksFile . words {- bind Key.Normal "C-D" $ Prompt.read "Bookmark all instances with tag:" "" $ \tags -> do uris <- mapM parseURI =<< sendCommandToAll "GET_URI" forM uris $ Bookmarks.addCustom myBookmarksFile . (`Bookmarks.Entry` words tags) void . Bookmarks.addCustom myBookmarksFile . (`Bookmarks.Entry` words tags) =<< getURI-} bind Key.Normal "M-d" $ Bookmarks.deleteWithTag myBookmarksFile ["-l", "10"] bind Key.Normal "C-l" $ Bookmarks.select myBookmarksFile ["-l", "10"] >>= load bind Key.Normal "C-L" $ Bookmarks.selectTag myBookmarksFile ["-l", "10"] >>= void . mapM (\uri -> io $ spawn "hbro" ["-u", (show uri)]) -- ("C-q"), webViewGetUri webView >>= maybe (return ()) (Queue.append), -- ("M-q"), \b -> do -- uri <- Queue.popFront -- load uri b), -- History bind Key.Normal "C-h" $ History.select myHistoryFile ["-l", "10"] >>= load . History.mURI -- Session --("M-l"), loadFromSession ["-l", "10"]) -- Settings bind Key.Normal "M-j" $ WS.toggle webSettingsEnableScripts >>= ((notify 5000 "Javascript disabled") ?? (notify 5000 "Javascript enabled")) bind Key.Normal "M-p" $ WS.toggle webSettingsEnablePlugins >>= ((notify 5000 "Plugins disabled") ?? (notify 5000 "Plugins enabled")) -- Web settings (cf Graphic.Gtk.WebKit.WebSettings) WS.modify webSettingsEnablePlugins $ const False WS.modify webSettingsEnableScripts $ const False WS.modify webSettingsEnablePageCache $ const True WS.modify webSettingsJSCanOpenWindowAuto $ const True WS.modify webSettingsUserAgent $ const firefoxUserAgent -- Scroll position in status bar setupScrollWidget =<< GUI.getObject castToLabel "scroll" -- Zoom level in status bar setupZoomWidget =<< GUI.getObject castToLabel "zoom" -- Load progress in status bar setupProgressWidget =<< GUI.getObject castToLabel "progress" -- Current URI in status bar setupURIWidget defaultURIColors defaultSecureURIColors =<< GUI.getObject castToLabel "uri" -- Keystrokes in status bar setupKeyStrokesWidget =<< GUI.getObject castToLabel "keys" -- Session manager --setupSession browser -- Favicon --_ <- on webView iconLoaded $ \uri -> do something return () myConfig :: Config K -> Config K myConfig = id . set homePage myHomePage . set onDownload myDownloadHook . set onLoadFinished myLoadFinishedHook -- Main function, expected to call 'hbro' main :: IO () main = hbro mySetup hbro-contrib-1.1.1.0/Hbro/0000755000000000000000000000000012101326015013307 5ustar0000000000000000hbro-contrib-1.1.1.0/Hbro/Settings.hs0000644000000000000000000000322612101326015015446 0ustar0000000000000000module Hbro.Settings where -- {{{ Import import Graphics.UI.Gtk.WebKit.WebSettings import System.Glib.Attributes -- }}} -- | Disable HTML5 database & local storage, plugins and scripts. paranoidWebSettings :: [AttrOp WebSettings] paranoidWebSettings = [ --webSettingsEnablePrivateBrowsing := False, -- Experimental -- Privacy webSettingsEnableHtml5Database := False, webSettingsEnableHtml5LocalStorage := False, webSettingsEnableOfflineWebApplicationCache := False, webSettingsEnableSiteSpecificQuirks := False, webSettingsUserAgent := firefoxUserAgent, -- Security webSettingsEnablePlugins := False, webSettingsEnableScripts := False, webSettingsJSCanOpenWindowAuto := False] -- {{{ User agents chromeUserAgent, epiphanyUserAgent, firefoxUserAgent, internetExplorerUserAgent, operaUserAgent, safariUserAgent :: String chromeUserAgent = "Mozilla/5.0 (X11; Linux x86_64) AppleWebKit/535.11 (KHTML, like Gecko) Chrome/17.0.963.12 Safari/535.11" epiphanyUserAgent = "Mozilla/5.0 (X11; U; Linux x86_64; en-US) AppleWebKit/534.7 (KHTML, like Gecko) Epiphany/2.30.6 Safari/534.7" firefoxUserAgent = "Mozilla/5.0 (X11; Linux i686; rv:2.0.1) Gecko/20100101 Firefox/4.0.1" internetExplorerUserAgent = "Mozilla/5.0 (compatible; MSIE 10.0; Windows NT 6.1; Trident/6.0)" operaUserAgent = "Opera/9.80 (X11; Linux x86_64; U; en) Presto/2.9.168 Version/11.50" safariUserAgent = "Mozilla/5.0 (Windows; U; Windows NT 6.1; en-US) AppleWebKit/533.20.25 (KHTML, like Gecko) Version/5.0.4 Safari/533.20.27" -- }}} hbro-contrib-1.1.1.0/Hbro/History.hs0000644000000000000000000000550212101326015015306 0ustar0000000000000000-- | Designed to be imported as @qualified@. module Hbro.History ( Entry(..), log, add, parseEntry, select ) where -- {{{ Imports import Hbro hiding(log) -- import Hbro.Error import Hbro.Gui import Hbro.Misc import Hbro.Network import Control.Exception import Control.Monad.Base import Control.Monad.Error import Data.Functor import Data.List import Data.Time import Network.URI (URI) import Prelude hiding(log) --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" -- }}} -- | Log current visited page to history file log :: (MonadBase IO m, ConfigReader n m, GUIReader n m, MonadError HError m) => FilePath -> m () log file = do uri <- getURI title <- getTitle timeZone <- io $ utcToLocalTime <$> getCurrentTimeZone now <- io $ timeZone <$> getCurrentTime add file (Entry now uri title) -- | Add a new entry to history file add :: (MonadBase IO m, ConfigReader n m, MonadError HError m) => FilePath -- ^ History file -> Entry -- ^ History entry to add -> m () add file newEntry = do logV $ "Adding new history entry <" ++ show (mURI newEntry) ++ ">" either (throwError . IOE) return =<< (io . try $ withFile file AppendMode (`hPutStrLn` show newEntry)) --either (\e -> errorHandler file' e >> return False) (const $ return True) result -- | Try to parse a String into a history Entry. parseEntry :: (MonadError HError m) => String -> m Entry parseEntry [] = throwError $ OtherError "While parsing history entry: empty input." parseEntry line = (parseEntry' . words) line parseEntry' :: (MonadError HError m) => [String] -> m Entry parseEntry' (d:t:u:t') = do time <- maybe (throwError $ OtherError "While parsing history entry: invalid date.") return $ parseTime defaultTimeLocale dateFormat (unwords [d, t]) uri <- parseURI u return $ Entry time uri (unwords t') parseEntry' _ = throwError $ OtherError "While parsing history entry: invalid format." -- | Open a dmenu with all (sorted alphabetically) history entries, and return the user's selection, if any select :: (Functor m, MonadBase IO m, MonadError HError m) => FilePath -- ^ Path to history file -> [String] -- ^ dmenu's commandline options -> m Entry -- ^ Selected history entry, if any select file dmenuOptions = do --either (\e -> errorHandler file' e >> return Nothing) (return . return) result parseEntry =<< dmenu dmenuOptions . unlines . reverse . sort . nub . lines =<< either (throwError . IOE) return =<< (io . try $ readFile file) hbro-contrib-1.1.1.0/Hbro/Download.hs0000644000000000000000000000074712101326015015422 0ustar0000000000000000module Hbro.Download where -- {{{ Imports import Hbro.Util import Control.Monad.Base import Network.URI import System.FilePath -- }}} aria, wget, axel :: (MonadBase IO m) => FilePath -> URI -> String -> m () aria destination uri filename = spawn "aria2c" [show uri, "-d", destination, "-o", filename] wget destination uri filename = spawn "wget" [show uri, "-O", destination filename] axel destination uri filename = spawn "axel" [show uri, "-o", destination filename] hbro-contrib-1.1.1.0/Hbro/Misc.hs0000644000000000000000000000465512101326015014550 0ustar0000000000000000module Hbro.Misc where -- {{{ Imports import Hbro -- import Hbro.Error import Hbro.Gui import Hbro.Network import Control.Exception import Control.Monad.Base import Control.Monad.Error -- import Data.Functor 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 (URI) import System.IO import System.Process -- }}} -- | Open dmenu with given input and return selected entry. dmenu :: (Functor m, MonadBase IO m, MonadError HError m) => [String] -- ^ dmenu's commandline options -> String -- ^ dmenu's input -> m String -- ^ Selected entry dmenu options input = do (in_, out, err, pid) <- io $ runInteractiveProcess "dmenu" options Nothing Nothing io $ hPutStr in_ input io $ hClose in_ output <- either (throwError . IOE) return =<< (io . try $ hGetLine out) io (hClose out) >> io (hClose err) >> (void . io $ waitForProcess pid) return output -- | List preceding URIs in dmenu and let the user select which one to load. goBackList :: (Functor m, MonadBase IO m, GUIReader n m, MonadError HError m) => [String] -> m URI goBackList dmenuOptions = do list <- io . webViewGetBackForwardList =<< readGUI webView n <- io $ webBackForwardListGetBackLength list backList <- io $ webBackForwardListGetBackListWithLimit list n dmenuList <- io $ mapM itemToEntry backList parseURIReference . head . words =<< (dmenu dmenuOptions . unlines . catMaybes) dmenuList -- | List succeeding URIs in dmenu and let the user select which one to load. goForwardList :: (Functor m, MonadBase IO m, GUIReader n m, MonadError HError m) => [String] -> m URI goForwardList dmenuOptions = do list <- io . webViewGetBackForwardList =<< readGUI webView n <- io $ webBackForwardListGetForwardLength list forwardList <- io $ webBackForwardListGetForwardListWithLimit list n dmenuList <- io $ mapM itemToEntry forwardList parseURIReference . head . words =<< (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 hbro-contrib-1.1.1.0/Hbro/Bookmarks.hs0000644000000000000000000001221712101326015015576 0ustar0000000000000000-- | Designed to be imported as @qualified@. module Hbro.Bookmarks ( Entry(..), add, addCustom, select, selectTag, deleteWithTag ) where -- {{{ Imports import Hbro -- import Hbro.Error import Hbro.Gui import Hbro.Misc import Hbro.Network import Control.Exception import Control.Monad hiding(forM_, mapM_) import Control.Monad.Base import Control.Monad.Error hiding(forM_, mapM_) --import qualified Data.ByteString.Char8 as B -- import Data.Foldable hiding(find, foldr) import Data.Functor import Data.List import Data.Maybe -- import Data.Random.Extras -- import Data.Random.RVar -- import Data.Random.Source.DevRandom import Network.URI (URI) import Prelude hiding(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 :: (MonadError HError m) => String -> m Entry parseEntry [] = throwError $ OtherError "While parsing bookmarks: empty entry." parseEntry line = return (words line) >>= (\(h:t) -> parseURI h >>= (\uri -> 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 current webpage to bookmarks with given tags add :: (Functor m, MonadBase IO m, GUIReader n m, MonadError HError m) => FilePath -> [String] -> m () add file tags = do uri <- getURI void . addCustom file $ Entry uri tags -- | Add a custom entry to bookmarks addCustom :: (MonadBase IO m, MonadError HError m) => FilePath -- ^ Bookmarks' database file -> Entry -- ^ New bookmarks entry -> m () addCustom file newEntry = do either (throwError . IOE) return =<< (io . try $ withFile file AppendMode (`hPutStrLn` show newEntry)) --either (\e -> errorHandler file' 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 :: (Functor m, MonadBase IO m, MonadError HError m) => FilePath -- ^ Bookmarks' database file -> [String] -- ^ dmenu's commandline options -> m URI select file dmenuOptions = do result <- either (throwError . IOE) return =<< (io . try $ readFile file) --either (\e -> errorHandler file' e >> return Nothing) (\x -> return $ Just x) result parseURIReference . last . words =<< (dmenu dmenuOptions . unlines . sort . nub . (map reformat) . lines $ result) 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 :: (Functor m, MonadBase IO m, MonadError HError m) => FilePath -- ^ Bookmarks' database file -> [String] -- ^ dmenu's commandline options -> m [URI] selectTag file dmenuOptions = do -- Read bookmarks file result <- either (throwError . IOE) return =<< (io . try $ readFile file) --file'' <- either (\e -> errorHandler file' e >> return Nothing) (\x -> return $ Just x) result entries <- mapM parseEntry . lines $ result let tags = unlines . sort . nub . words . unwords . foldr (union . mTags) [] $ entries -- Let user select a tag (map mURI) . (\t -> filter (hasTag t) entries) <$> dmenu dmenuOptions tags -- --popOldest :: PortableFilePath -> String -> IO (Maybe URI) --popOldest file tags = do -- Return a random Bookmark entry with a given tag, while removing it from bookmarks. -- popRandom :: PortableFilePath -- -> String -- -> IO (Maybe URI) -- popRandom file tags = do -- file' <- resolve file -- result <- try . readFile $ file' -- file'' <- either (\e -> errorHandler file' e >> return Nothing) (\x -> return $ Just x) result -- forM_ file'' $ \f -> do -- let selection = choiceExtract . lines $ f -- forM_ selection $ \s -> do -- (newLines, value) <- runRVar s DevURandom -- renameFile file' (file' ++ ".old") -- writeFile file' . unlines . nub $ newLines -- return . parseURIReference . last . words $ value -- | Remove all bookmarks entries matching the given tag. deleteWithTag :: (Functor m, MonadBase IO m, MonadError HError m) => FilePath -- ^ Bookmarks' database file -> [String] -- ^ dmenu's commandline options -> m () deleteWithTag file dmenuOptions = do result <- either (throwError . IOE) return =<< (io . try $ readFile file) --file'' <- either (\e -> errorHandler file' e >> return Nothing) (\x -> return $ Just x) result entries <- mapM parseEntry . lines $ result let tags = (unlines . sort . nub . words . unwords . (foldr (union . mTags) [])) entries tag <- dmenu dmenuOptions tags io $ writeFile (file ++ ".old") $ unlines (map show entries) io $ writeFile file $ (unlines . (map show) . (filter (not . (hasTag tag)))) entries hbro-contrib-1.1.1.0/Hbro/StatusBar.hs0000644000000000000000000001322312101326015015554 0ustar0000000000000000module Hbro.StatusBar where -- {{{ Imports import Hbro.Config import Hbro.Keys as Key import Hbro.Gui import Hbro.Util import Control.Monad hiding(forM_, mapM_) import Control.Monad.Base -- import Control.Monad.Reader 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 as N import Prelude hiding(mapM_) import System.Glib.Signals -- }}} -- | Write current scroll position in the given Label. setupScrollWidget :: (MonadBase IO m, GUIReader n m) => Label -> m () setupScrollWidget widget = do adjustment <- io . scrolledWindowGetVAdjustment =<< readGUI scrollWindow io $ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 32767 32767 32767}] io . void . 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) ++ "%" io $ labelSetText widget "0%" -- | /!\\ Doesn't work for now. -- Write current zoom level in the given Label. setupZoomWidget :: (MonadBase IO m, GUIReader n m) => Label -> m () setupZoomWidget widget = do io $ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 65535 65535}] readGUI webView >>= io . webViewGetZoomLevel >>= io . labelSetMarkup widget . escapeMarkup . show -- | Write current keystrokes state in the given 'Label' setupKeyStrokesWidget :: (MonadBase IO m, ConfigWriter m m, GUIReader m m) => Label -> m () setupKeyStrokesWidget widget = do io $ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 65535 0}] writeConfig onKeyStroke $ io . labelSetText widget . intercalate " " . map Key.serialize -- | Write current load progress in the given 'Label'. setupProgressWidget :: (MonadBase IO m, GUIReader n m) => Label -> m () setupProgressWidget widget = do wv <- readGUI webView -- Load started io . void . on wv loadStarted $ \_ -> do labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0}] labelSetText widget "0%" -- Progress changed io . void . on wv progressChanged $ \progress' -> do labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 65535 0}] labelSetText widget $ show progress' ++ "%" -- Load finished io . void . on wv loadFinished $ \_ -> do labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 0 65535 0}] labelSetText widget "100%" -- Error io . void . on wv 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 :: (MonadBase IO m, GUIReader n m) => URIColors -> URIColors -> Label -> m () setupURIWidget normalColors secureColors widget = do wv <- readGUI webView -- URI changed _ <- io $ on wv loadCommitted $ \_ -> (mapM_ (labelSetURI normalColors secureColors widget)) =<< ((>>= N.parseURIReference) `fmap` (webViewGetUri wv)) -- Link (un)hovered _ <- io $ on wv hoveringOverLink $ \_title hoveredURI -> do uri <- webViewGetUri wv forM_ (hoveredURI >>= N.parseURIReference) $ labelSetURI normalColors secureColors widget unless (isJust hoveredURI) $ forM_ (uri >>= N.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 20000 20000 20000, mQuery = Color 20000 20000 20000, mFragment = Color 10000 10000 65535 } defaultSecureURIColors :: URIColors defaultSecureURIColors = defaultURIColors { mHost = Color 50000 50000 0 }