hbro-contrib 0.9.1.0 → 1.0.0.0
raw patch · 10 files changed
+295/−342 lines, 10 filesdep +monad-controldep +mtldep +transformersdep ~hbro
Dependencies added: monad-control, mtl, transformers
Dependency ranges changed: hbro
Files
- Hbro/Bookmarks.hs +59/−59
- Hbro/Clipboard.hs +0/−19
- Hbro/Download.hs +6/−5
- Hbro/History.hs +36/−33
- Hbro/Misc.hs +36/−15
- Hbro/Settings.hs +32/−0
- Hbro/StatusBar.hs +41/−41
- Hbro/WebSettings.hs +0/−32
- examples/hbro.hs +76/−131
- hbro-contrib.cabal +9/−7
Hbro/Bookmarks.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE FlexibleContexts #-}+-- | Designed to be imported as @qualified@. module Hbro.Bookmarks ( Entry(..), add,@@ -8,16 +10,16 @@ ) where -- {{{ Imports-import Hbro.Core---import Hbro.Gui-import Hbro.Types hiding(mURI)-import Hbro.Util+import Hbro+import Hbro.Misc import Control.Exception import Control.Monad hiding(forM_, mapM_)+import Control.Monad.Error hiding(forM_, mapM_)+import Control.Monad.Reader hiding(forM_, mapM_) --import qualified Data.ByteString.Char8 as B-import Data.Foldable hiding(find, foldr)+-- import Data.Foldable hiding(find, foldr) import Data.Functor import Data.List import Data.Maybe@@ -26,7 +28,7 @@ -- import Data.Random.Source.DevRandom -import Network.URI+import Network.URI (URI) import Prelude hiding(catch, mapM_) @@ -44,84 +46,84 @@ -- }}} -- | Try to parse a String into a bookmark Entry.-parseEntry :: String -> Maybe Entry-parseEntry [] = Nothing-parseEntry line = return (words line) +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 -> listToMaybe t - >> (return $ Entry uri t)))+ >>= (\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 :: PortableFilePath -> [String] -> K () -add file tags = withURI $ \uri -> io . void . addCustom file $ Entry uri tags+add :: (Functor m, MonadIO m, MonadReader r m, HasWebView r, MonadError HError m) => IO FilePath -> [String] -> m ()+add file tags = do+ uri <- getURI+ void . addCustom file $ Entry uri tags -- | Add a custom entry to bookmarks-addCustom :: PortableFilePath -- ^ Bookmarks' database file- -> Entry -- ^ New bookmarks entry- -> IO Bool+addCustom :: (MonadIO m, MonadError HError m)+ => IO FilePath -- ^ Bookmarks' database file+ -> Entry -- ^ New bookmarks entry+ -> m () 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- + file' <- io file+ 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 :: PortableFilePath -- ^ Bookmarks' database file+select :: (Functor m, MonadIO m, MonadError HError m)+ => IO FilePath -- ^ Bookmarks' database file -> [String] -- ^ dmenu's commandline options- -> IO (Maybe URI)+ -> m URI select file dmenuOptions = do- file' <- resolve file- result <- try $ readFile file' - - 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 . ((parseURIReference . last . words) =<<))+ 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 + 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 :: PortableFilePath -- ^ Bookmarks' database file+selectTag :: (Functor m, MonadIO m, MonadError HError m)+ => IO FilePath -- ^ Bookmarks' database file -> [String] -- ^ dmenu's commandline options- -> IO (Maybe [URI])+ -> m [URI] 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 = (catMaybes . map parseEntry . lines) <$> file''- let tags = (unlines . sort . nub . words . unwords . (foldr (union . mTags) [])) <$> entries+ file' <- io 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- tag <- (maybe (return Nothing) (dmenu dmenuOptions) tags)- return $ (return . (map mURI) . (\t -> filter (hasTag t) (maybe [] id entries))) =<< 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 +-- -> 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 +-- forM_ selection $ \s -> do -- (newLines, value) <- runRVar s DevURandom- + -- renameFile file' (file' ++ ".old") -- writeFile file' . unlines . nub $ newLines @@ -129,20 +131,18 @@ -- | Remove all bookmarks entries matching the given tag.-deleteWithTag :: PortableFilePath -- ^ Bookmarks' database file+deleteWithTag :: (Functor m, MonadIO m, MonadError HError m)+ => IO FilePath -- ^ Bookmarks' database file -> [String] -- ^ dmenu's commandline options- -> IO ()+ -> m () 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- let entries = (catMaybes . (map parseEntry) . lines) f - let tags = (unlines . sort . nub . words . unwords . (foldr (union . mTags) [])) entries+ file' <- io file+ result <- either (throwError . IOE) return =<< (io . try $ readFile file')+ --file'' <- either (\e -> errorHandler file' e >> return Nothing) (\x -> return $ Just x) result - tag <- (dmenu dmenuOptions tags) - forM_ tag (\t -> do- writeFile (file' ++ ".old") $ unlines (map show entries)- writeFile file' $ (unlines . (map show) . (filter (not . (hasTag t)))) entries- return ())+ 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/Clipboard.hs
@@ -1,19 +0,0 @@-module Hbro.Clipboard where---- {{{ Imports-import Hbro.Core-import Hbro.Types-import Hbro.Util--import Graphics.UI.Gtk.General.Clipboard--- }}}----- | Write given String to primary clipboard.-toClipboard :: String -> IO ()-toClipboard text = clipboardGet selectionPrimary >>= (`clipboardSetText` text)- -withClipboard :: (String -> K ()) -> K ()-withClipboard callback = do- clip <- io $ clipboardGet selectionPrimary - mapK2 (clipboardRequestText clip) (maybe (return ()) callback)
Hbro/Download.hs view
@@ -1,16 +1,17 @@ module Hbro.Download where -- {{{ Imports-import Hbro.Types import Hbro.Util +import Control.Monad.IO.Class+ import Network.URI import System.FilePath -- }}} -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]+aria, wget, axel :: (MonadIO m) => IO FilePath -> URI -> String -> m ()+aria path' uri filename = io $ path' >>= \destination -> spawn "aria2c" [show uri, "-d", destination, "-o", filename]+wget path' uri filename = io $ path' >>= \destination -> spawn "wget" [show uri, "-O", destination </> filename]+axel path' uri filename = io $ path' >>= \destination -> spawn "axel" [show uri, "-o", destination </> filename]
Hbro/History.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE FlexibleContexts #-}+-- | Designed to be imported as @qualified@. module Hbro.History ( Entry(..), log,@@ -7,25 +9,26 @@ ) where -- {{{ Imports-import Hbro.Core-import Hbro.Types-import Hbro.Util+import Hbro+import Hbro.Misc import Control.Exception---import Control.Monad.Reader+import Control.Monad.Error+-- import Control.Monad.IO.Class+import Control.Monad.Reader import Data.Functor import Data.List import Data.Time -import Network.URI+import Network.URI (URI) import Prelude hiding(log) --import System.IO.Error import System.IO import System.Locale--- }}} +-- }}} -- {{{ Type definitions data Entry = Entry {@@ -42,44 +45,44 @@ -- }}} -- | 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 ()+log :: (MonadIO m, MonadReader r m, HasWebView r, MonadError HError m) => IO 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 :: PortableFilePath -- ^ History file- -> Entry -- ^ History entry to add- -> IO Bool+add :: (MonadIO m, MonadError HError m)+ => IO FilePath -- ^ History file+ -> Entry -- ^ History entry to add+ -> m () 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 + file' <- io file+ 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 :: String -> Maybe Entry-parseEntry [] = Nothing+parseEntry :: (MonadError HError m) => String -> m Entry+parseEntry [] = throwError $ OtherError "While parsing history entry: empty input." parseEntry line = (parseEntry' . words) line -parseEntry' :: [String] -> Maybe Entry+parseEntry' :: (MonadError HError m) => [String] -> m Entry parseEntry' (d:t:u:t') = do- time <- parseTime defaultTimeLocale dateFormat (unwords [d, t])+ 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' _ = Nothing+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 :: PortableFilePath -- ^ Path to history file+select :: (Functor m, MonadIO m, MonadError HError m)+ => IO FilePath -- ^ Path to history file -> [String] -- ^ dmenu's commandline options- -> IO (Maybe Entry) -- ^ Selected history entry, if any+ -> m Entry -- ^ Selected history entry, if any select file dmenuOptions = do- file' <- resolve file- result <- try $ readFile file'- - either (\e -> errorHandler file' e >> return Nothing) (return . return) result- >>= (return . ((return . unlines . reverse . sort . nub . lines) =<<))- >>= (maybe (return Nothing) (dmenu dmenuOptions))- >>= (return . (parseEntry =<<))++ --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/Misc.hs view
@@ -1,11 +1,15 @@+{-# LANGUAGE FlexibleContexts #-} module Hbro.Misc where -- {{{ Imports-import Hbro.Core-import Hbro.Types-import Hbro.Util+import Hbro -import Data.Functor+import Control.Exception+import Control.Monad.Error+-- import Control.Monad.IO.Class+import Control.Monad.Reader++-- import Data.Functor import Data.Maybe -- import Graphics.UI.Gtk.Display.Label@@ -13,32 +17,49 @@ import Graphics.UI.Gtk.WebKit.WebHistoryItem import Graphics.UI.Gtk.WebKit.WebView -import Network.URI+import Network.URI (URI) --- import System.IO+import System.IO+import System.Process -- }}} +-- | Open dmenu with given input and return selected entry.+dmenu :: (Functor m, MonadIO 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 :: [String] -> K (Maybe URI)+goBackList :: (Functor m, MonadIO m, MonadReader r m, HasWebView r, MonadError HError m) => [String] -> m URI goBackList dmenuOptions = do- list <- with (mWebView . mGUI) webViewGetBackForwardList+ list <- io . webViewGetBackForwardList =<< asks _webview n <- io $ webBackForwardListGetBackLength list backList <- io $ webBackForwardListGetBackListWithLimit list n dmenuList <- io $ mapM itemToEntry backList- - (>>= (parseURIReference . head . words)) <$> (io . dmenu dmenuOptions . unlines . catMaybes) dmenuList- + parseURIReference . head . words =<< (dmenu dmenuOptions . unlines . catMaybes) dmenuList++ -- | List succeeding URIs in dmenu and let the user select which one to load.-goForwardList :: [String] -> K (Maybe URI)+goForwardList :: (Functor m, MonadIO m, MonadReader r m, HasWebView r, MonadError HError m) => [String] -> m URI goForwardList dmenuOptions = do- list <- with (mWebView . mGUI) webViewGetBackForwardList+ list <- io . webViewGetBackForwardList =<< asks _webview n <- io $ webBackForwardListGetForwardLength list forwardList <- io $ webBackForwardListGetForwardListWithLimit list n dmenuList <- io $ mapM itemToEntry forwardList- - (>>= (parseURIReference . head . words)) `fmap` (io . dmenu dmenuOptions . unlines . catMaybes) dmenuList++ parseURIReference . head . words =<< (dmenu dmenuOptions . unlines . catMaybes) dmenuList itemToEntry :: WebHistoryItem -> IO (Maybe String)
+ Hbro/Settings.hs view
@@ -0,0 +1,32 @@+module 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/StatusBar.hs view
@@ -1,13 +1,15 @@ module Hbro.StatusBar where -- {{{ Imports-import Hbro.Core+-- import Hbro.Core --import Hbro.Keys import Hbro.Gui import Hbro.Types import Hbro.Util import Control.Monad hiding(forM_, mapM_)+import Control.Monad.IO.Class+import Control.Monad.Reader hiding(forM_, mapM_) import Data.Foldable import Data.List@@ -22,7 +24,7 @@ import Graphics.UI.Gtk.Scrolling.ScrolledWindow import Graphics.UI.Gtk.WebKit.WebView -import Network.URI+import Network.URI as N import Prelude hiding(mapM_) @@ -32,67 +34,65 @@ -- notify :: Environment -> String -> Color -> IO () -- notify env text color = do--- widget <- builderGetObject ((mBuilder . mGUI) env) castToLabel "feedback"+-- widget <- builderGetObject ((_builder . _UI) env) castToLabel "feedback" -- labelSetAttributes widget [Attrforeground{ paStart = 0, paEnd = -1, paColor = color }] -- labelSetMarkupTemporary widget text 5000 -- | Write current scroll position in the given Label.-setupScrollWidget :: Label -> K ()+setupScrollWidget :: (MonadIO m, MonadReader r m, HasScrollWindow r) => Label -> m () setupScrollWidget widget = do- adjustment <- with (mScrollWindow . mGUI) $ scrolledWindowGetVAdjustment- io $ do- labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 32767 32767 32767}]+ adjustment <- io . scrolledWindowGetVAdjustment =<< asks _scrollwindow+ io $ 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%"+ _ <- io $ 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 :: Label -> K ()+setupZoomWidget :: (MonadIO m, MonadReader r m, HasWebView r) => Label -> m () 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 + asks _webview >>= io . webViewGetZoomLevel >>= io . labelSetMarkup widget . escapeMarkup . show -- | -printInLabel :: String -> (String, Bool) -> K (String, Bool)+printInLabel :: (MonadIO m, MonadReader r m, HasGUI r) => String -> (String, Bool) -> m (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}]- - case match of- True -> labelSetText widget []- _ -> labelSetText widget keystrokes+ io $ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 65535 0}]+ io $ case match of+ True -> labelSetText widget []+ _ -> labelSetText widget keystrokes return (keystrokes, match) -- | Write current load progress in the given Label.-setupProgressWidget :: Label -> K ()-setupProgressWidget widget = with (mWebView . mGUI) $ \webView -> do+setupProgressWidget :: (MonadIO m, MonadReader r m, HasWebView r) => Label -> m ()+setupProgressWidget widget = do+ webView <- asks _webview -- Load started- _ <- on webView loadStarted $ \_ -> do+ _ <- io $ 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+ _ <- io $ 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+ _ <- io $ on webView loadFinished $ \_ -> do labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 0 65535 0}] labelSetText widget "100%" -- Error- _ <- on webView loadError $ \_ _ _ -> do+ _ <- io $ on webView loadError $ \_ _ _ -> do labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0}] labelSetText widget "ERROR" return False@@ -101,18 +101,18 @@ -- | Write current URI, or the destination of a hovered link, in the given Label.-setupURIWidget :: URIColors -> URIColors -> Label -> K ()-setupURIWidget normalColors secureColors widget = with (mWebView . mGUI) $ \webView -> do+setupURIWidget :: (MonadIO m, MonadReader r m, HasWebView r) => URIColors -> URIColors -> Label -> m ()+setupURIWidget normalColors secureColors widget = do+ webView <- asks _webview -- URI changed- _ <- on webView loadCommitted $ \_ ->- (mapM_ (labelSetURI normalColors secureColors widget)) =<< ((>>= parseURIReference) `fmap` (webViewGetUri webView))- + _ <- io $ on webView loadCommitted $ \_ ->+ (mapM_ (labelSetURI normalColors secureColors widget)) =<< ((>>= N.parseURIReference) `fmap` (webViewGetUri webView)) -- Link (un)hovered- _ <- on webView hoveringOverLink $ \_title hoveredURI -> do+ _ <- io $ 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)+ forM_ (hoveredURI >>= N.parseURIReference) $ labelSetURI normalColors secureColors widget+ unless (isJust hoveredURI) $ forM_ (uri >>= N.parseURIReference) (labelSetURI normalColors secureColors widget) return ()
− Hbro/WebSettings.hs
@@ -1,32 +0,0 @@-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"--- }}}
examples/hbro.hs view
@@ -1,30 +1,28 @@-{-# LANGUAGE DoRec #-}+{-# LANGUAGE FlexibleContexts #-} module Main where -- {{{ Imports+import Hbro import qualified Hbro.Bookmarks as Bookmarks-import Hbro.Boot-import Hbro.Clipboard-import Hbro.Config-import Hbro.Core+import qualified Hbro.Clipboard as Clipboard 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 qualified Hbro.Prompt as Prompt import Hbro.Session-import Hbro.Socket+import Hbro.Settings import Hbro.StatusBar-import Hbro.Types-import Hbro.Util-import Hbro.WebSettings+import qualified Hbro.Webkit.WebSettings as WS +import Control.Conditional import Control.Monad hiding(forM_, mapM_)+import Control.Monad.Error hiding(forM_, mapM_)+import Control.Monad.IO.Class +import Data.Default import Data.Foldable import Data.Functor+import Data.Monoid import Data.Time import Graphics.UI.Gtk.Abstract.Widget@@ -40,7 +38,7 @@ import Graphics.UI.Gtk.WebKit.WebSettings import Graphics.UI.Gtk.Windows.Window -import Network.URI+import Network.URI hiding(parseURI, parseURIReference) import Prelude hiding(mapM_) @@ -51,164 +49,111 @@ import System.Glib.Attributes import System.Glib.Signals -- import System.Posix.Process-import System.Process +import System.Process -- }}} --- Main function, expected to call launchHbro.-main :: IO ()-main = hbro myConfig- -- {{{ Configuration structures--- Any field you don't override will --- use the defaults defined in Hbro.Types.Config.+-- 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,--- mCommandsList = myCommandsList,- mHooks = myHooks-}--myHooks = defaultHooks {--- mBackForward = myBackForward,- mDownload = myDownloadHook,--- mFormResubmitted = myFormResubmitted,--- mFormSubmitted = myFormSubmitted,- mKeyPressed = emacsKeyHandler myKeys ["M-x"] >=> void . (printInLabel "keys"),--- mLinkClicked = myLinkClicked,- mLoadFinished = myLoadFinished,--- mMIMEDisposition = myMIMEDisposition,--- mNewWindow = myNewWindowHook,--- mOtherNavigation = myOtherNavigation,--- mReload = myReload,- mStartUp = myStartUp--- mTitleChanged = myTitleChanged-}+myConfig = def {+ __UIFile = myUIFile,+ __homePage = myHomePage} -- }}} -- {{{ Constant parameters-myHomePage = "https://duckduckgo.com"--myUIFile, myHistoryFile, myBookmarksFile, myDownloadDirectory :: PortableFilePath-myUIFile directories = (mConfiguration directories) </> "ui.xml"-myHistoryFile directories = (mData directories) </> "history"-myBookmarksFile directories = (mData directories) </> "bookmarks"-myDownloadDirectory = mHome--- }}}---- {{{ Hooks-myDownloadHook :: URI -> String -> Int -> K ()-myDownloadHook uri filename _size = io $ Download.aria myDownloadDirectory uri filename+myHomePage = URI "https:" (Just $ URIAuth "" "//duckduckgo.com" "") "" "" "" -myLoadFinished :: K ()-myLoadFinished = History.log myHistoryFile+myUIFile, myHistoryFile, myBookmarksFile, myDownloadDirectory :: IO FilePath+myUIFile = getUserConfigDir "hbro" >/> "ui.xml"+myHistoryFile = getUserDataDir "hbro" >/> "history"+myBookmarksFile = getUserDataDir "hbro" >/> "bookmarks"+myDownloadDirectory = getHomeDirectory -- }}} -- {{{ Keys -- Note that this example is suited for an azerty keyboard. myKeys :: KeysList-myKeys = defaultKeyBindings ++ [+myKeys = def <> KeysList [ -- Browse- ("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- ("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]),+ ("C-<Left>", goBackList ["-l", "10"] >>= loadURI),+ ("C-<Right>", goForwardList ["-l", "10"] >>= loadURI),+ ("C-g", Prompt.read "DuckDuckGo search" "" (loadURI <=< parseURIReference . ("https://duckduckgo.com/html?q=" ++) . escapeURIString isAllowedInURI)), -- Bookmarks- ("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)) + ("C-d", Prompt.read "Bookmark with tags:" "" $ Bookmarks.add myBookmarksFile . words),+ ("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 ),- ("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)),+ ("M-d", Bookmarks.deleteWithTag myBookmarksFile ["-l", "10"]),+ ("C-l", Bookmarks.select myBookmarksFile ["-l", "10"] >>= loadURI),+ ("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 -- loadURI uri b), -- History- ("C-h", io (History.select myHistoryFile ["-l", "10"]) >>= mapM_ loadURI . (return . (History.mURI) =<<))- + ("C-h", History.select myHistoryFile ["-l", "10"] >>= loadURI . History.mURI),+ -- Session --("M-l"), loadFromSession ["-l", "10"])+-- Settings+ ("M-j", WS.toggle webSettingsEnableScripts >>= ((notify 5000 "Javascript disabled") ?? (notify 5000 "Javascript enabled"))),+ ("M-p", WS.toggle webSettingsEnablePlugins >>= ((notify 5000 "Plugins disabled") ?? (notify 5000 "Plugins enabled"))) ] -- }}} --- {{{ Web settings--- Commented out lines correspond to default values.-myWebSettings :: [AttrOp WebSettings]-myWebSettings = [--- SETTING VALUE - --webSettingsCursiveFontFamily := "serif",- --webSettingsDefaultFontFamily := "sans-serif",- --webSettingsFantasyFontFamily := ,- webSettingsMonospaceFontFamily := "consolas",- --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 := False,- 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 := firefoxUserAgent- --webSettingsUserStylesheetUri := Nothing,- --webSettingsZoomStep := 0.1- ]--- }}}+myDownloadHook :: DownloadHook+myDownloadHook = DownloadHook $ \uri filename _size -> Download.aria myDownloadDirectory uri filename --- {{{ Setup-myStartUp :: K ()-myStartUp = do+myKeyHook :: KeyHook+myKeyHook = emacsKeyHandler myKeys ["M-x"]-- >=> void . (printInLabel "keys")++myLoadFinishedHook = LoadFinishedHook $ History.log myHistoryFile++-- Main function, expected to call launchHbro.+main :: IO ()+main = hbro myConfig $ Setup $ do+-- Hooks+ afterKeyPressed myKeyHook+ onDownload myDownloadHook+ onLoadFinished myLoadFinishedHook+ onNavigationRequest def+ onNewWebView def+ onNewWindow def+ onResourceOpened def+ onTitleChanged def++-- Web settings (cf Graphic.Gtk.WebKit.WebSettings)+ WS.modify webSettingsMonospaceFontFamily $ const "consolas"+ WS.modify webSettingsEnableDeveloperExtras $ const True+ WS.modify webSettingsEnablePlugins $ const False+ WS.modify webSettingsEnablePrivateBrowsing $ const False+ WS.modify webSettingsEnableScripts $ const False+ WS.modify webSettingsEnableUniversalAccessFromFileUris $ const True+ WS.modify webSettingsEnableXssAuditor $ const True+ WS.modify webSettingsEnablePageCache $ const True+ WS.modify webSettingsJSCanOpenWindowAuto $ const True+ WS.modify webSettingsSpellCheckingLang $ const $ Just "en_US"+ WS.modify webSettingsUserAgent $ const firefoxUserAgent+ -- Scroll position in status bar setupScrollWidget =<< getObject castToLabel "scroll" -- Zoom level in status bar setupZoomWidget =<< getObject castToLabel "zoom"- + -- Load progress in status bar setupProgressWidget =<< getObject castToLabel "progress"- + -- Current URI in status bar setupURIWidget defaultURIColors defaultSecureURIColors =<< getObject castToLabel "uri"- + -- Session manager --setupSession browser- + -- Favicon --_ <- on webView iconLoaded $ \uri -> do something return ()--- }}}
hbro-contrib.cabal view
@@ -1,13 +1,13 @@ Name: hbro-contrib-Version: 0.9.1.0+Version: 1.0.0.0 Synopsis: Third-party extensions to hbro.--- Description: +-- Description: Homepage: https://github.com/k0ral/hbro-contrib/ Category: Browser,Web License: OtherLicense License-file: LICENSE--- Copyright: +-- Copyright: Author: koral Maintainer: koral at mailoo dot org @@ -27,7 +27,9 @@ filepath, glib, gtk >= 0.12.3,- hbro >= 0.9.1.0,+ hbro >= 1.0.0.0,+ monad-control,+ mtl, network, old-locale, pango,@@ -36,15 +38,15 @@ -- random-fu, text, time,+ transformers, unix, webkit Exposed-modules: Hbro.Bookmarks,- Hbro.Clipboard, Hbro.Download, Hbro.History, Hbro.Misc, Hbro.Session,- Hbro.StatusBar,- Hbro.WebSettings+ Hbro.Settings,+ Hbro.StatusBar Ghc-options: -Wall