hbro-contrib 0.8.0.0 → 0.9.0.0
raw patch · 13 files changed
+346/−503 lines, 13 filesdep ~hbro
Dependency ranges changed: hbro
Files
- Hbro/Bookmarks.hs +69/−33
- Hbro/BookmarksQueue.hs +0/−81
- Hbro/Clipboard.hs +8/−6
- Hbro/Download.hs +5/−12
- Hbro/History.hs +29/−25
- Hbro/Misc.hs +19/−58
- Hbro/Session.hs +28/−28
- Hbro/StatusBar.hs +52/−69
- Hbro/WebSettings.hs +32/−0
- README.rst +2/−1
- examples/hbro.hs +75/−185
- examples/ui.xml +20/−0
- hbro-contrib.cabal +7/−5
Hbro/Bookmarks.hs view
@@ -1,15 +1,16 @@ module Hbro.Bookmarks ( Entry(..), add,+ addCustom, select, selectTag, deleteWithTag ) where -- {{{ Imports---import Hbro.Core+import Hbro.Core --import Hbro.Gui---import Hbro.Types+import Hbro.Types hiding(mURI) import Hbro.Util import Control.Exception@@ -17,9 +18,14 @@ --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 import Prelude hiding(catch, mapM_)@@ -49,27 +55,32 @@ 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+-- | Add current webpage to bookmarks with given tags+add :: PortableFilePath -> [String] -> K () +add file tags = withURI $ \uri -> io . void . addCustom file $ Entry uri tags++-- | Add a custom entry to bookmarks+addCustom :: PortableFilePath -- ^ Bookmarks' database file+ -> Entry -- ^ New bookmarks entry+ -> IO Bool+addCustom file newEntry = do+ file' <- resolve file+ result <- 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 :: FilePath -- ^ Bookmarks' database file- -> [String] -- ^ dmenu's commandline options- -> IO (Maybe String)-select bookmarksFile dmenuOptions = do- result <- try $ readFile bookmarksFile +select :: PortableFilePath -- ^ Bookmarks' database file+ -> [String] -- ^ dmenu's commandline options+ -> IO (Maybe URI)+select file dmenuOptions = do+ file' <- resolve file+ result <- try $ readFile file' - either (\e -> errorHandler bookmarksFile e >> return Nothing) (\x -> return $ Just x) result+ either (\e -> errorHandler file' 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) =<<))+ >>= (return . ((parseURIReference . last . words) =<<)) - reformat :: String -> String reformat line = unwords $ tags' ++ [uri] where@@ -77,36 +88,61 @@ 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+selectTag :: PortableFilePath -- ^ 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+selectTag file dmenuOptions = do+-- Read bookmarks file+ file' <- resolve file+ result <- try $ readFile file'+ file'' <- either (\e -> errorHandler file' 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 entries = (catMaybes . map parseEntry . lines) <$> file''+ let tags = (unlines . sort . nub . words . unwords . (foldr (union . mTags) [])) <$> entries - -- Let user select a tag+-- Let user select a tag tag <- (maybe (return Nothing) (dmenu dmenuOptions) tags) return $ (return . (map mURI) . (\t -> filter (hasTag t) (maybe [] id entries))) =<< tag +-- |+--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 :: FilePath -- ^ Bookmarks' database file- -> [String] -- ^ dmenu's commandline options+deleteWithTag :: PortableFilePath -- ^ 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+deleteWithTag file dmenuOptions = 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+ 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+ writeFile (file' ++ ".old") $ unlines (map show entries)+ writeFile file' $ (unlines . (map show) . (filter (not . (hasTag t)))) entries return ())
− Hbro/BookmarksQueue.hs
@@ -1,81 +0,0 @@-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
@@ -1,17 +1,19 @@ module Hbro.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.General.Clipboard -- }}} --- | Copy current URI in clipboard.+-- | Write given String to primary clipboard. toClipboard :: String -> IO () toClipboard text = clipboardGet selectionPrimary >>= (`clipboardSetText` text) -withClipboard :: (Maybe String -> IO ()) -> IO ()-withClipboard callback = clipboardGet selectionPrimary >>= (`clipboardRequestText` callback)+withClipboard :: (String -> K ()) -> K ()+withClipboard callback = do+ clip <- io $ clipboardGet selectionPrimary + mapK2 (clipboardRequestText clip) (maybe (return ()) callback)
Hbro/Download.hs view
@@ -4,20 +4,13 @@ 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]++aria, wget, axel :: PortableFilePath -> URI -> String -> IO ()+aria path' uri filename = resolve path' >>= \destination -> spawn "aria2c" [show uri, "-d", destination, "-o", filename]+wget path' uri filename = resolve path' >>= \destination -> spawn "wget" [show uri, "-O", destination </> filename]+axel path' uri filename = resolve path' >>= \destination -> spawn "axel" [show uri, "-o", destination </> filename]
Hbro/History.hs view
@@ -1,24 +1,27 @@ module Hbro.History ( Entry(..),+ log, add, parseEntry, select ) where -- {{{ Imports---import Hbro.Core---import Hbro.Types+import Hbro.Core+import Hbro.Types import Hbro.Util import Control.Exception --import Control.Monad.Reader +import Data.Functor import Data.List-import Data.Time.Format-import Data.Time.LocalTime+import Data.Time import Network.URI +import Prelude hiding(log)+ --import System.IO.Error import System.IO import System.Locale@@ -38,13 +41,22 @@ dateFormat = "%F %T" -- }}} --- | Add a new entry to history's database-add :: FilePath -- ^ Path to history file- -> Entry -- ^ History entry to add+-- | Log current visited page to history file+log :: PortableFilePath -> K ()+log file = withURI $ \uri -> withTitle $ \title -> io $ do+ timeZone <- utcToLocalTime <$> getCurrentTimeZone+ now <- timeZone <$> getCurrentTime+ + add file (Entry now uri title) >> return ()++-- | Add a new entry to history file+add :: PortableFilePath -- ^ 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 +add file newEntry = do+ file' <- resolve file+ result <- 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 :: String -> Maybe Entry@@ -60,22 +72,14 @@ 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+select :: PortableFilePath -- ^ Path to history file+ -> [String] -- ^ dmenu's commandline options+ -> IO (Maybe Entry) -- ^ Selected history entry, if any+select file dmenuOptions = do+ file' <- resolve file+ result <- try $ readFile file' - either (\e -> errorHandler historyFile e >> return Nothing) (return . return) result+ either (\e -> errorHandler file' 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
@@ -1,74 +1,44 @@ module Hbro.Misc where -- {{{ Imports---import Hbro.Core---import Hbro.Types+import Hbro.Core+import Hbro.Types import Hbro.Util +import Data.Functor import Data.Maybe -import Graphics.UI.Gtk.Display.Label+-- 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+-- 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+goBackList :: [String] -> K (Maybe URI)+goBackList dmenuOptions = do+ list <- with (mWebView . mGUI) webViewGetBackForwardList+ n <- io $ webBackForwardListGetBackLength list+ backList <- io $ webBackForwardListGetBackListWithLimit list n+ dmenuList <- io $ mapM itemToEntry backList - (>>= (parseURIReference . head . words)) `fmap` (dmenu dmenuOptions $ (unlines . catMaybes) dmenuList)+ (>>= (parseURIReference . head . words)) <$> (io . 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+goForwardList :: [String] -> K (Maybe URI)+goForwardList dmenuOptions = do+ list <- with (mWebView . mGUI) webViewGetBackForwardList+ n <- io $ webBackForwardListGetForwardLength list+ forwardList <- io $ webBackForwardListGetForwardListWithLimit list n+ dmenuList <- io $ mapM itemToEntry forwardList - (>>= (parseURIReference . head . words)) `fmap` (dmenu dmenuOptions $ (unlines . catMaybes) dmenuList)+ (>>= (parseURIReference . head . words)) `fmap` (io . dmenu dmenuOptions . unlines . catMaybes) dmenuList itemToEntry :: WebHistoryItem -> IO (Maybe String)@@ -78,12 +48,3 @@ 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
@@ -2,40 +2,40 @@ -- {{{ Imports --import Hbro.Types-import Hbro.Util+-- import Hbro.Util -import Data.Foldable-import qualified Data.Text as T-import qualified Data.Text.IO as T+-- 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 Graphics.UI.Gtk.General.General+-- import Graphics.UI.Gtk.WebKit.WebView hiding(webViewGetUri) -import Prelude hiding(mapM_)+-- import Prelude hiding(mapM_) -import System.Directory-import System.Environment-import System.Glib.Signals-import System.IO-import System.Posix.Process-import System.Process +-- 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 ()+--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 ()
Hbro/StatusBar.hs view
@@ -1,9 +1,11 @@ module Hbro.StatusBar where -- {{{ Imports+import Hbro.Core --import Hbro.Keys+import Hbro.Gui import Hbro.Types---import Hbro.Util +import Hbro.Util import Control.Monad hiding(forM_, mapM_) @@ -15,7 +17,7 @@ import Graphics.Rendering.Pango.Layout import Graphics.UI.Gtk.Display.Label-import Graphics.UI.Gtk.Gdk.EventM+--import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.Misc.Adjustment import Graphics.UI.Gtk.Scrolling.ScrolledWindow import Graphics.UI.Gtk.WebKit.WebView@@ -28,87 +30,70 @@ -- }}} --- | 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+-- notify :: Environment -> String -> Color -> IO ()+-- notify env text color = do+-- widget <- builderGetObject ((mBuilder . mGUI) env) castToLabel "feedback"+-- labelSetAttributes widget [Attrforeground{ paStart = 0, paEnd = -1, paColor = color }]+-- labelSetMarkupTemporary widget text 5000 - _ <- 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%"-+-- | Write current scroll position in the given Label.+setupScrollWidget :: Label -> K ()+setupScrollWidget widget = do+ adjustment <- with (mScrollWindow . mGUI) $ scrolledWindowGetVAdjustment+ io $ do+ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 32767 32767 32767}]+ + _ <- 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>"+setupZoomWidget :: Label -> K ()+setupZoomWidget widget = do+ io $ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 65535 65535}] + with (mWebView . mGUI) webViewGetZoomLevel >>= io . labelSetMarkup widget . escapeMarkup . show - -- | -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}- ]+printInLabel :: String -> (String, Bool) -> K (String, Bool)+printInLabel label (keystrokes, match) = do + widget <- getObject castToLabel label+ io $ do+ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 65535 0}] --- Write keystrokes state to label- case (modifiers, isSuffixOf "<Escape>" keys) of- (_ , True) -> labelSetText widget []- ([], _) -> labelSetText widget keys- (_, _) -> labelSetText widget (show modifiers ++ keys)+ case match of+ True -> labelSetText widget []+ _ -> labelSetText widget keystrokes - return result- + return (keystrokes, match) -- | Write current load progress in the given Label.-statusBarLoadProgress :: Label -> WebView -> IO ()-statusBarLoadProgress widget webView = do+setupProgressWidget :: Label -> K ()+setupProgressWidget widget = with (mWebView . mGUI) $ \webView -> do -- Load started _ <- on webView loadStarted $ \_ -> do- labelSetAttributes widget [- AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0}- ]+ 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}- ]+ 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}- ]+ 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}- ]+ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0}] labelSetText widget "ERROR" return False @@ -116,8 +101,8 @@ -- | 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+setupURIWidget :: URIColors -> URIColors -> Label -> K ()+setupURIWidget normalColors secureColors widget = with (mWebView . mGUI) $ \webView -> do -- URI changed _ <- on webView loadCommitted $ \_ -> (mapM_ (labelSetURI normalColors secureColors widget)) =<< ((>>= parseURIReference) `fmap` (webViewGetUri webView))@@ -141,10 +126,9 @@ let i:j:k:l:_ = map length [ uriScheme uri,- maybe "" uriRegName (uriAuthority uri),+ maybe [] uriRegName (uriAuthority uri), uriPath uri,- uriQuery uri- ]+ uriQuery uri] labelSetAttributes widget $ [ AttrWeight{ paStart = 0, paEnd = -1, paWeight = WeightBold },@@ -152,8 +136,7 @@ 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 }- ]+ AttrForeground{ paStart = i+2+j+k+l, paEnd = -1, paColor = mFragment colors }] labelSetText widget (show uri) @@ -174,7 +157,7 @@ mHost = Color 50000 50000 50000, mPort = Color 65535 0 0, mUser = Color 0 65535 0,- mPath = Color 0 65535 65535,+ mPath = Color 20000 20000 20000, mQuery = Color 20000 20000 20000, mFragment = Color 10000 10000 65535 }
+ Hbro/WebSettings.hs view
@@ -0,0 +1,32 @@+module Hbro.WebSettings 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"+-- }}}
README.rst view
@@ -2,9 +2,10 @@ hbro-contrib ============ -This package gathers third-party extensions to *hbro_*.+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
examples/hbro.hs view
@@ -3,8 +3,8 @@ -- {{{ Imports import qualified Hbro.Bookmarks as Bookmarks-import qualified Hbro.BookmarksQueue as Queue import Hbro.Clipboard+import Hbro.Config import Hbro.Core import qualified Hbro.Download as Download import Hbro.Gui@@ -12,15 +12,18 @@ import qualified Hbro.History as History import Hbro.Keys import Hbro.Misc+import qualified Hbro.Prompt as Prompt import Hbro.Session import Hbro.Socket import Hbro.StatusBar import Hbro.Types import Hbro.Util+import Hbro.WebSettings import Control.Monad hiding(forM_, mapM_) import Data.Foldable+import Data.Functor import Data.Time import Graphics.UI.Gtk.Abstract.Widget@@ -33,9 +36,7 @@ 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@@ -53,137 +54,90 @@ -- }}} -- 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,+-- {{{ Configuration structures+-- Any field you don't override will +-- use the defaults defined in Hbro.Types.Config.+myConfig :: Config+myConfig = defaultConfig {+-- mSocketDir = mySocketDirectory,+ mUIFile = myUIFile, mHomePage = myHomePage, mWebSettings = myWebSettings,- mSetup = mySetup,- mDownloadHook = myDownloadHook+-- mCommandsList = myCommandsList,+ mHooks = myHooks } --- 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"+myHooks = defaultHooks {+-- mBackForward = myBackForward,+ mDownload = myDownloadHook,+-- mFormResubmitted = myFormResubmitted,+-- mFormSubmitted = myFormSubmitted,+ mKeyPressed = manageSequentialKeys (defaultKeyHandler myKeys) >=> void . (printInLabel "keys"),+-- mLinkClicked = myLinkClicked,+ mLoadFinished = myLoadFinished,+-- mMIMEDisposition = myMIMEDisposition,+-- mNewWindow = myNewWindowHook,+-- mOtherNavigation = myOtherNavigation,+-- mReload = myReload,+ mStartUp = myStartUp+-- mTitleChanged = myTitleChanged+}+-- }}} --- 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+-- {{{ Constant parameters+myHomePage = "https://duckduckgo.com" --- How to handle keystrokes-myKeyEventHandler :: KeyEventCallback -> ConnectId WebView -> WebView -> EventM EKey Bool-myKeyEventHandler = advancedKeyEventHandler+myUIFile, myHistoryFile, myBookmarksFile, myDownloadDirectory :: PortableFilePath+myUIFile directories = (mConfiguration directories) </> "ui.xml"+myHistoryFile directories = (mData directories) </> "history"+myBookmarksFile directories = (mData directories) </> "bookmarks"+myDownloadDirectory = mHome+-- }}} -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+-- {{{ Hooks+myDownloadHook :: URI -> String -> Int -> K ()+myDownloadHook uri filename _size = io $ Download.aria myDownloadDirectory uri filename +myLoadFinished :: K ()+myLoadFinished = History.log myHistoryFile+-- }}} -- {{{ 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)+myKeys :: KeysList+myKeys = defaultKeyBindings ++ [ -- 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 ()),-+ ("C-<Left>", goBackList ["-l", "10"] >>= mapM_ loadURI),+ ("C-<Right>", goForwardList ["-l", "10"] >>= mapM_ loadURI),+ ("C-g", Prompt.read "DuckDuckGo search" [] (mapM_ loadURI . parseURIReference . ("https://duckduckgo.com/html?q=" ++) . escapeURIString isAllowedInURI)), -- 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),-+ ("C-y", withURI $ io . toClipboard . show),+ ("M-y", withTitle $ io . toClipboard),+ ("C-p", withClipboard $ mapM_ loadURI . parseURIReference),+ ("M-p", withClipboard $ \uri -> io $ spawn "hbro" ["-u", uri]), -- 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+ ("C-d", Prompt.read "Bookmark with tags:" [] $ Bookmarks.add myBookmarksFile . words),+ ("C-D", Prompt.read "Bookmark all instances with tag:" [] $ \tags -> do+ (map parseURI <$> sendCommandToAll "GET_URI")+ >>= mapM (mapM_ $ \uri -> (io . Bookmarks.addCustom myBookmarksFile) $ Bookmarks.Entry uri (words tags)) + >> (withURI $ \uri -> (io . void . Bookmarks.addCustom myBookmarksFile) $ Bookmarks.Entry uri (words tags)) + ),+ ("M-d", io $ Bookmarks.deleteWithTag myBookmarksFile ["-l", "10"]),+ ("C-l", io (Bookmarks.select myBookmarksFile ["-l", "10"]) >>= mapM_ loadURI),+ ("C-L", io (Bookmarks.selectTag myBookmarksFile ["-l", "10"]) >>= mapM_ (\uris -> mapM (\uri -> io . void $ spawn "hbro" ["-u", (show uri)]) uris)),+-- ("C-q"), webViewGetUri webView >>= maybe (return ()) (Queue.append),+-- ("M-q"), \b -> do -- uri <- Queue.popFront -- loadURI uri b), -- History- (([Control], "h"), History.select historyFile ["-l", "10"] >>= mapM_ ((webViewLoadUri webView) . History.mURI))+ ("C-h", io (History.select myHistoryFile ["-l", "10"]) >>= mapM_ loadURI . (return . (History.mURI) =<<)) -- Session- --(([Alt], "l"), loadFromSession ["-l", "10"])+ --("M-l"), loadFromSession ["-l", "10"]) ] -- }}} @@ -195,7 +149,7 @@ --webSettingsCursiveFontFamily := "serif", --webSettingsDefaultFontFamily := "sans-serif", --webSettingsFantasyFontFamily := ,- --webSettingsMonospaceFontFamily := "monospace",+ webSettingsMonospaceFontFamily := "consolas", --webSettingsSansFontFamily := "sans-serif", --webSettingsSerifFontFamily := "serif", --webSettingsDefaultFontSize := ,@@ -206,12 +160,12 @@ --webSettingsAutoShrinkImages := True, --webSettingsDefaultEncoding := "iso-8859-1", --webSettingsEditingBehavior := EditingBehaviorWindows,- --webSettingsEnableCaretBrowsing := False,+ --webSettingsEnableCaretBrowsing := False, webSettingsEnableDeveloperExtras := True, --webSettingsEnableHtml5Database := True, --webSettingsEnableHtml5LocalStorage := True, --webSettingsEnableOfflineWebApplicationCache := True,- webSettingsEnablePlugins := True,+ webSettingsEnablePlugins := False, webSettingsEnablePrivateBrowsing := False, -- Experimental webSettingsEnableScripts := False, --webSettingsEnableSpellChecking := False,@@ -228,94 +182,30 @@ --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"+ webSettingsUserAgent := firefoxUserAgent --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+myStartUp :: K ()+myStartUp = do -- Scroll position in status bar- scrollLabel <- getLabel "scroll"- setupScrollWidget scrollLabel scrolledWindow+ setupScrollWidget =<< getObject castToLabel "scroll" -- Zoom level in status bar- zoomLabel <- getLabel "zoom"- statusBarZoomLevel zoomLabel webView+ setupZoomWidget =<< getObject castToLabel "zoom" -- Load progress in status bar- progressLabel <- getLabel "progress"- statusBarLoadProgress progressLabel webView+ setupProgressWidget =<< getObject castToLabel "progress" -- Current URI in status bar- uriLabel <- getLabel "uri"- setupURIWidget defaultURIColors defaultSecureURIColors uriLabel webView+ setupURIWidget defaultURIColors defaultSecureURIColors =<< getObject castToLabel "uri" -- 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
examples/ui.xml view
@@ -100,6 +100,26 @@ </packing> </child> ++ <!-- Notify bar -->+ <child>+ <object class="GtkHBox" id="notificationBox">+ <property name="homogeneous">False</property>+ <property name="spacing">5</property>+ + <child>+ <object class="GtkLabel" id="notificationLabel">+ <property name="single-line-mode">True</property>+ <property name="xalign">0</property>+ </object>+ </child>+ </object>++ <packing>+ <property name="fill">False</property>+ <property name="expand">False</property>+ </packing>+ </child> </object></child> </object> </interface>
hbro-contrib.cabal view
@@ -1,8 +1,8 @@ Name: hbro-contrib-Version: 0.8.0.0+Version: 0.9.0.0 Synopsis: Third-party extensions to hbro. -- Description: -Homepage: http://projects.haskell.org/hbro-contrib/+Homepage: https://github.com/k0ral/hbro-contrib/ Category: Browser,Web License: OtherLicense@@ -27,22 +27,24 @@ filepath, glib, gtk,- hbro,+ hbro >= 0.9.0.0, network, old-locale, pango, process,+ -- random-extras,+ -- random-fu, text, time, unix, webkit Exposed-modules: Hbro.Bookmarks,- Hbro.BookmarksQueue, Hbro.Clipboard, Hbro.Download, Hbro.History, Hbro.Misc, Hbro.Session,- Hbro.StatusBar+ Hbro.StatusBar,+ Hbro.WebSettings Ghc-options: -Wall