hbro-contrib 1.1.1.0 → 1.2.0.0
raw patch · 9 files changed
+338/−323 lines, 9 filesdep +classy-preludedep +containersdep +gtk3dep −directorydep −filepathdep −gtkdep ~hbrodep ~mtl
Dependencies added: classy-prelude, containers, gtk3, network-uri, parsec, safe, system-fileio, webkitgtk3
Dependencies removed: directory, filepath, gtk, network, old-locale, webkit
Dependency ranges changed: hbro, mtl
Files
- Hbro/Bookmarks.hs +97/−75
- Hbro/Download.hs +9/−9
- Hbro/History.hs +75/−60
- Hbro/Misc.hs +22/−28
- Hbro/Settings.hs +17/−13
- Hbro/StatusBar.hs +33/−41
- examples/hbro.hs +47/−76
- examples/ui.xml +12/−6
- hbro-contrib.cabal +26/−15
Hbro/Bookmarks.hs view
@@ -1,11 +1,15 @@--- | Designed to be imported as @qualified@.-module Hbro.Bookmarks (- Entry(..),- add,- addCustom,- select,- selectTag,- deleteWithTag+-- | Simple bookmarks system: bookmarks are a list of tagged URIs.+--+-- This module is designed to be imported as @qualified@.+module Hbro.Bookmarks+ ( Entry(..)+ , add+ , add'+ , addCustom+ , Hbro.Bookmarks.select+ , Hbro.Bookmarks.select'+ , selectByTag+ , deleteByTag ) where -- {{{ Imports@@ -13,106 +17,119 @@ -- 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 Control.Monad.Reader hiding(mapM) ---import qualified Data.ByteString.Char8 as B--- import Data.Foldable hiding(find, foldr)-import Data.Functor-import Data.List-import Data.Maybe+import qualified Data.Set as Set -- import Data.Random.Extras -- import Data.Random.RVar -- import Data.Random.Source.DevRandom +import Filesystem hiding(readFile, writeFile) -import Network.URI (URI)+import Network.URI -import Prelude hiding(mapM_)+import Safe -import System.IO+import Text.Parsec hiding(many)+import Text.Parsec.Text -- }}} -- {{{ Type definitions-data Entry = Entry {- mURI :: URI,- mTags :: [String]-}+data Entry = Entry+ { _uri :: URI+ , _tags :: Set Text+ } -instance Show Entry where- show (Entry uri tags) = unwords $ (show uri):tags+instance Describable Entry where+ describe (Entry uri tags) = unwords $ (tshow uri):(Set.toList 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))+-- Error message+-- invalidBookmarkEntry :: Text -> Text+-- invalidBookmarkEntry = ("Invalid bookmark entry: " ++) --- | Check if the given bookmark Entry is tagged with the given tag.-hasTag :: String -> Entry -> Bool-hasTag tag = isJust . (find $ (==) tag) . mTags+-- | Return bookmarks file+getBookmarksFile :: (BaseIO m) => m FilePath+getBookmarksFile = getAppDataDirectory "hbro" >/> "bookmarks" +-- | Try to parse a Text into a history Entry.+entry :: Parser Entry+entry = do+ spaces+ u <- (some $ satisfy isAllowedInURI) <?> "URI"+ uri <- (maybe mzero return $ parseURI u) <?> "URI"+ some space+ tags <- many $ noneOf "\n"+ return $ Entry uri (Set.fromList . words $ pack tags)+++-- | Check if the given bookmark 'Entry' is tagged with the given tag.+hasTag :: Text -> Entry -> Bool+hasTag tag = member tag . _tags+ -- | 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 :: (BaseIO m, MonadReader r m, HasGUI r, MonadError Text m, ToSet Text tags) => tags -> m ()+add tags = (`add'` tags) =<< getBookmarksFile +-- | Like 'add', but you can specify the bookmarks file path+add' :: (BaseIO m, MonadReader r m, Hbro.Gui.HasGUI r, MonadError Text m, ToSet Text tags) => FilePath -> tags -> m ()+add' file tags = do+ uri <- getCurrentURI+ void . addCustom file $ Entry uri (toSet tags)+ -- | Add a custom entry to bookmarks-addCustom :: (MonadBase IO m, MonadError HError m)- => FilePath -- ^ Bookmarks' database file- -> Entry -- ^ New bookmarks entry+addCustom :: (BaseIO m, MonadError Text m)+ => FilePath -- ^ Bookmarks file+ -> Entry -- ^ Custom bookmark 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+addCustom file newEntry = io $ withFile file AppendMode (`hPutStrLn` describe newEntry) -- | 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+select :: (ControlIO m, MonadError Text m)+ => [Text] -- ^ dmenu's commandline options -> m URI-select file dmenuOptions = do- result <- either (throwError . IOE) return =<< (io . try $ readFile file)+select dmenuOptions = (`select'` dmenuOptions) =<< getBookmarksFile - --either (\e -> errorHandler file' e >> return Nothing) (\x -> return $ Just x) result- parseURIReference . last . words =<< (dmenu dmenuOptions . unlines . sort . nub . (map reformat) . lines $ result)+-- | Like 'select', but you can specify the bookmarks file path+select' :: (ControlIO m, MonadError Text m) => FilePath -> [Text] -> m URI+select' file dmenuOptions = do+ maybe (throwError "ERROR") return . parseURIReference . unpack . lastDef "" . words =<< dmenu dmenuOptions . unlines . sort . ordNub . (map reformat) . lines =<< readFile file -reformat :: String -> String+reformat :: Text -> Text reformat line = unwords $ tags' ++ [uri] where uri:tags = words line- tags' = sort $ map (\tag -> '[':(tag ++ "]")) tags+ tags' = sort $ map (("[" ++) . (++ "]")) 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)+selectByTag :: (ControlIO m, MonadError Text m)+ => [Text] -- ^ dmenu's commandline options+ -> m [URI]+selectByTag dmenuOptions = (`selectByTag'` dmenuOptions) =<< getBookmarksFile++-- | Like 'selectByTag', but you can specify the bookmarks file path+selectByTag' :: (ControlIO m, MonadError Text m) => FilePath -- ^ Bookmarks' database file- -> [String] -- ^ dmenu's commandline options+ -> [Text] -- ^ dmenu's commandline options -> m [URI]-selectTag file dmenuOptions = do+selectByTag' 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+ result <- readFile file - entries <- mapM parseEntry . lines $ result- let tags = unlines . sort . nub . words . unwords . foldr (union . mTags) [] $ entries+ entries <- mapM (either (throwError . tshow) return . runParser entry () "(unknown)") . lines $ result+ let tags = unlines . Set.toList . foldl' Set.union Set.empty $ map _tags entries -- Let user select a tag- (map mURI) . (\t -> filter (hasTag t) entries) <$> dmenu dmenuOptions tags+ (map _uri) . (\t -> filter (hasTag t) entries) <$> dmenu dmenuOptions tags -----popOldest :: PortableFilePath -> String -> IO (Maybe URI)+--popOldest :: PortableFilePath -> Text -> IO (Maybe URI) --popOldest file tags = do -- Return a random Bookmark entry with a given tag, while removing it from bookmarks. -- popRandom :: PortableFilePath--- -> String+-- -> Text -- -> IO (Maybe URI) -- popRandom file tags = do -- file' <- resolve file@@ -125,23 +142,28 @@ -- (newLines, value) <- runRVar s DevURandom -- renameFile file' (file' ++ ".old")--- writeFile file' . unlines . nub $ newLines+-- writeFile file' . unlines . ordNub $ newLines -- return . parseURIReference . last . words $ value -- | Remove all bookmarks entries matching the given tag.-deleteWithTag :: (Functor m, MonadBase IO m, MonadError HError m)+deleteByTag :: (ControlIO m, MonadError Text m)+ => [Text] -- ^ dmenu's commandline options+ -> m ()+deleteByTag dmenuOptions = (`deleteByTag'` dmenuOptions) =<< getBookmarksFile++-- | Like 'selectByTag', but you can specify the bookmarks file path+deleteByTag' :: (ControlIO m, MonadError Text m) => FilePath -- ^ Bookmarks' database file- -> [String] -- ^ dmenu's commandline options+ -> [Text] -- ^ 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+deleteByTag' file dmenuOptions = do+ result <- readFile file - entries <- mapM parseEntry . lines $ result- let tags = (unlines . sort . nub . words . unwords . (foldr (union . mTags) [])) entries+ entries <- mapM (either (throwError . tshow) return . runParser entry () "(unknown)") . lines $ result+ let tags = unlines . Set.toList . (foldl' Set.union Set.empty) $ map _tags entries tag <- dmenu dmenuOptions tags- io $ writeFile (file ++ ".old") $ unlines (map show entries)- io $ writeFile file $ (unlines . (map show) . (filter (not . (hasTag tag)))) entries+ writeFile (file <.> "old") $ unlines (describe <$> entries)+ writeFile file $ (unlines . map describe . (filter (not . (hasTag tag)))) entries
Hbro/Download.hs view
@@ -1,17 +1,17 @@ module Hbro.Download where -- {{{ Imports-import Hbro.Util--import Control.Monad.Base+import Hbro.Prelude 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]+aria, wget, axel :: (BaseIO m)+ => FilePath -- ^ Destination directory+ -> URI -- ^ URI to download+ -> Text -- ^ Destination file name+ -> m ()+aria destination uri filename = spawn "aria2c" [show uri, "-d", unpack $ fpToText destination, "-o", unpack filename]+wget destination uri filename = spawn "wget" [show uri, "-O", unpack $ fpToText (destination </> fpFromText filename)]+axel destination uri filename = spawn "axel" [show uri, "-o", unpack $ fpToText (destination </> fpFromText filename)]
Hbro/History.hs view
@@ -1,88 +1,103 @@ -- | Designed to be imported as @qualified@.-module Hbro.History (- Entry(..),- log,- add,- parseEntry,- select-) where+module Hbro.History+ ( Entry(..)+ , log+ , log'+ , add+ , add'+ , entry+ , Hbro.History.select+ , Hbro.History.select'+ ) where -- {{{ Imports-import Hbro hiding(log)--- import Hbro.Error+-- import Hbro+import Hbro.Core+import Hbro.Error import Hbro.Gui+import Hbro.Logger import Hbro.Misc-import Hbro.Network+import Hbro.Prelude -import Control.Exception-import Control.Monad.Base-import Control.Monad.Error+import Control.Monad.Reader -import Data.Functor-import Data.List import Data.Time -import Network.URI (URI)+import Filesystem (getAppDataDirectory, withTextFile, IOMode(..)) -import Prelude hiding(log)+import Network.URI ---import System.IO.Error-import System.IO-import System.Locale+import Text.Parsec hiding(many)+import Text.Parsec.Text -- }}} -- {{{ Type definitions-data Entry = Entry {- mTime :: LocalTime,- mURI :: URI,- mTitle :: String-}+data Entry = Entry+ { _time :: LocalTime+ , _uri :: URI+ , _title :: Text+ } -instance Show Entry where- show (Entry time uri title) = unwords [(formatTime defaultTimeLocale dateFormat time), show uri, title]+instance Describable Entry where+ describe (Entry time uri title) = unwords [pack (formatTime defaultTimeLocale dateFormat time), tshow 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+-- Error message+-- invalidHistoryEntry :: Text -> Text+-- invalidHistoryEntry = ("Invalid history entry: " ++)++getHistoryFile :: (BaseIO m) => m FilePath+getHistoryFile = getAppDataDirectory "hbro" >/> "history"++-- | Log current visited page to history database+log :: (ControlIO m, MonadReader r m, HasGUI r, MonadError Text m) => m ()+log = log' =<< getHistoryFile++-- | Like 'log', but you can specify the history file path+log' :: (ControlIO m, MonadReader r m, HasGUI r, MonadError Text m) => FilePath -> m ()+log' file = do+ uri <- getCurrentURI+ title <- getPageTitle 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+ add' file (Entry now uri title) --- | 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+-- | Add a new entry to history database+add :: (ControlIO m, MonadError Text m) => Entry -> m ()+add newEntry = (`add'` newEntry) =<< getHistoryFile -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+-- | Like 'add', but you can specify the history file path+add' :: (ControlIO m, MonadError Text m) => FilePath -> Entry -> m ()+add' file newEntry = do+ debugM "hbro.history" $ "Adding new entry <" ++ tshow (_uri newEntry) ++ "> to history file <" ++ fpToText file ++ ">"+ handleIO (throwError . tshow) . io $ withTextFile file AppendMode (`hPutStrLn` describe newEntry) - return $ Entry time uri (unwords t')-parseEntry' _ = throwError $ OtherError "While parsing history entry: invalid format."+-- | Try to parse a Text into a history Entry.+entry :: Parser Entry+entry = do+ spaces+ time1 <- some $ noneOf " "+ some space+ time2 <- some $ noneOf " "+ time <- maybe mzero return $ parseTime defaultTimeLocale dateFormat (unwords [time1, time2])+ some space+ u <- some $ satisfy isAllowedInURI+ uri <- maybe mzero return $ parseURI u+ some space+ tags <- many (noneOf "\n")+ return $ Entry time uri (pack tags) -- | 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+select :: (ControlIO m, MonadError Text m)+ => [Text] -- ^ 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)+select dmenuOptions = (`select'` dmenuOptions) =<< getHistoryFile++-- | Like 'select', but you can specify the history file path+select' :: (ControlIO m, MonadError Text m) => FilePath -> [Text] -> m Entry+select' file dmenuOptions = do+ either (throwError . tshow) return . runParser entry () "(unknown)" =<< dmenu dmenuOptions . unlines . reverse . sort . ordNub . lines =<< readFile file
Hbro/Misc.hs view
@@ -2,68 +2,62 @@ -- {{{ Imports import Hbro--- import Hbro.Error-import Hbro.Gui-import Hbro.Network--import Control.Exception-import Control.Monad.Base-import Control.Monad.Error+import Hbro.Gui as Gui --- import Data.Functor-import Data.Maybe+import Control.Monad.Reader hiding(mapM) --- 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 Network.URI.Monadic -import System.IO+import Safe+ 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+-- This will block effectively the current thread.+dmenu :: (ControlIO m, MonadError Text m)+ => [Text] -- ^ dmenu's commandline options+ -> Text -- ^ dmenu's input+ -> m Text -- ^ Selected entry+dmenu options input = handleIO (\_ -> throwError "Dmenu canceled.") $ do+ (in_, out, err, pid) <- io $ runInteractiveProcess "dmenu" (map unpack options) Nothing Nothing+ hPut in_ input io $ hClose in_ - output <- either (throwError . IOE) return =<< (io . try $ hGetLine out)+ output <- hGetLine out - io (hClose out) >> io (hClose err) >> (void . io $ waitForProcess pid)+ io $ hClose out >> hClose err >> (void $ 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 :: (ControlIO m, MonadReader r m, HasGUI r, MonadError Text m) => [Text] -> m URI goBackList dmenuOptions = do- list <- io . webViewGetBackForwardList =<< readGUI webView+ list <- io . webViewGetBackForwardList =<< Gui.get webViewL n <- io $ webBackForwardListGetBackLength list backList <- io $ webBackForwardListGetBackListWithLimit list n dmenuList <- io $ mapM itemToEntry backList - parseURIReference . head . words =<< (dmenu dmenuOptions . unlines . catMaybes) dmenuList+ parseURIReference . headDef "" . 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 :: (ControlIO m, MonadReader r m, HasGUI r, MonadError Text m) => [Text] -> m URI goForwardList dmenuOptions = do- list <- io . webViewGetBackForwardList =<< readGUI webView+ list <- io . webViewGetBackForwardList =<< Gui.get webViewL n <- io $ webBackForwardListGetForwardLength list forwardList <- io $ webBackForwardListGetForwardListWithLimit list n dmenuList <- io $ mapM itemToEntry forwardList - parseURIReference . head . words =<< (dmenu dmenuOptions . unlines . catMaybes) dmenuList+ parseURIReference . headDef "" . words =<< (dmenu dmenuOptions . unlines . catMaybes) dmenuList -itemToEntry :: WebHistoryItem -> IO (Maybe String)+itemToEntry :: WebHistoryItem -> IO (Maybe Text) itemToEntry item = do title <- webHistoryItemGetTitle item uri <- webHistoryItemGetUri item
Hbro/Settings.hs view
@@ -1,31 +1,35 @@ module Hbro.Settings where -- {{{ Import-import Graphics.UI.Gtk.WebKit.WebSettings+import Hbro.Gui+import Hbro.Prelude+import qualified Hbro.Webkit.WebSettings as Settings -import System.Glib.Attributes+import Control.Monad.Reader++import Graphics.UI.Gtk.WebKit.WebSettings -- }}} -- | Disable HTML5 database & local storage, plugins and scripts.-paranoidWebSettings :: [AttrOp WebSettings]-paranoidWebSettings = [+setParanoidWebSettings :: (BaseIO m, MonadReader t m, HasGUI t) => m ()+setParanoidWebSettings = do --webSettingsEnablePrivateBrowsing := False, -- Experimental -- Privacy- webSettingsEnableHtml5Database := False,- webSettingsEnableHtml5LocalStorage := False,- webSettingsEnableOfflineWebApplicationCache := False,- webSettingsEnableSiteSpecificQuirks := False,- webSettingsUserAgent := firefoxUserAgent,+ Settings.set webSettingsEnableHtml5Database False+ Settings.set webSettingsEnableHtml5LocalStorage False+ Settings.set webSettingsEnableOfflineWebApplicationCache False+ Settings.set webSettingsEnableSiteSpecificQuirks False+ Settings.set webSettingsUserAgent firefoxUserAgent -- Security- webSettingsEnablePlugins := False,- webSettingsEnableScripts := False,- webSettingsJSCanOpenWindowAuto := False]+ Settings.set webSettingsEnablePlugins False+ Settings.set webSettingsEnableScripts False+ Settings.set 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"+firefoxUserAgent = "Mozilla/5.0 (Windows NT 6.1; WOW64; rv:26.0) Gecko/20100101 Firefox/26.0" 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,18 +1,12 @@+{-# LANGUAGE ViewPatterns #-} module 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 Hbro.Gui as Gui+import Hbro.Prelude hiding(on) -import Data.Foldable-import Data.List-import Data.Maybe+import Control.Monad.Reader hiding(forM_, mapM_) import Graphics.Rendering.Pango.Enums import Graphics.Rendering.Pango.Layout@@ -25,17 +19,15 @@ 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}]+installScrollWidget :: (BaseIO m, MonadReader r m, HasGUI r) => Label -> m ()+installScrollWidget widget = do+ adjustment <- io . scrolledWindowGetVAdjustment =<< Gui.get scrollWindowL+ io $ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = gray}] io . void . onValueChanged adjustment $ do current <- adjustmentGetValue adjustment@@ -44,54 +36,54 @@ page <- adjustmentGetPageSize adjustment case upper-lower-page of- 0 -> labelSetText widget "ALL"+ 0 -> labelSetText widget (asText "ALL") x -> labelSetText widget $ show (round $ current/x*100) ++ "%" - io $ labelSetText widget "0%"+ io $ labelSetText widget (asText "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+installZoomWidget :: (BaseIO m, MonadReader r m, HasGUI r) => Label -> m ()+installZoomWidget widget = do io $ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 65535 65535}]- readGUI webView >>= io . webViewGetZoomLevel >>= io . labelSetMarkup widget . escapeMarkup . show+ Gui.get webViewL >>= 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}]+installKeyStrokesWidget :: (BaseIO m, MonadReader r m, HasGUI r, HasHooks n r, BaseIO n) => Label -> m ()+installKeyStrokesWidget widget = do+ io $ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = yellow}] - writeConfig onKeyStroke $ io . labelSetText widget . intercalate " " . map Key.serialize+ Key.set onKeyPressedL $ io . labelSetText widget . unwords . map describe -- | Write current load progress in the given 'Label'.-setupProgressWidget :: (MonadBase IO m, GUIReader n m) => Label -> m ()-setupProgressWidget widget = do- wv <- readGUI webView+installProgressWidget :: (BaseIO m, MonadReader r m, HasGUI r) => Label -> m ()+installProgressWidget widget = do+ wv <- Gui.get webViewL -- Load started io . void . on wv loadStarted $ \_ -> do- labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0}]- labelSetText widget "0%"+ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = red}]+ labelSetText widget (asText "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' ++ "%"+ io . void . on wv progressChanged $ \progress -> do+ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = yellow}]+ labelSetText widget $ tshow progress ++ "%" -- Load finished io . void . on wv loadFinished $ \_ -> do- labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 0 65535 0}]- labelSetText widget "100%"+ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = green}]+ labelSetText widget (asText "100%") -- Error- io . void . on wv loadError $ \_ _ _ -> do- labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0}]- labelSetText widget "ERROR"+ io . void . on wv loadError $ \_ (asText -> _a) _ -> do+ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = red}]+ labelSetText widget (asText "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+installURIWidget :: (BaseIO m, MonadReader r m, HasGUI r) => URIColors -> URIColors -> Label -> m ()+installURIWidget normalColors secureColors widget = do+ wv <- Gui.get webViewL -- URI changed _ <- io $ on wv loadCommitted $ \_ -> (mapM_ (labelSetURI normalColors secureColors widget)) =<< ((>>= N.parseURIReference) `fmap` (webViewGetUri wv))
examples/hbro.hs view
@@ -1,120 +1,91 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds, FlexibleContexts, NoImplicitPrelude, OverloadedStrings, PackageImports #-} module Main where -- {{{ Imports import Hbro import qualified Hbro.Bookmarks as Bookmarks import qualified Hbro.Clipboard as Clipboard+import Hbro.Config (homePageL)+import qualified Hbro.Config as Config import qualified Hbro.Download as Download import qualified Hbro.Gui as GUI+import Hbro.Gui.PromptBar import qualified Hbro.History as History import Hbro.Keys as Key+import Hbro.Keys.Model ((.|))+import Hbro.Keys.Monadic 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.Gui.PromptBar.Signals import Hbro.StatusBar-import qualified Hbro.Webkit.WebSettings as WS+import Hbro.WebView.Hooks as WebView+import Hbro.WebView.Signals+import qualified Hbro.Webkit.WebSettings as WebSettings -import Control.Conditional-import Control.Lens hiding((??))-import Control.Monad hiding(forM_, mapM_)+import qualified Data.Set as Set +import Filesystem+ 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+import qualified Network.URI as N+import Network.URI.Monadic -- }}} -myHomePage = URI "http:" (Just $ URIAuth "" "//www.google.com" "") "" "" "" -- Seriously ?+myHomePage = fromJust . N.parseURI $ "http://www.google.com" -- Download to $HOME-myDownloadHook :: URI -> String -> Int -> K ()-myDownloadHook uri filename _size = do+myDownloadHook :: (BaseIO m) => Download -> m ()+myDownloadHook (Download uri filename _size) = do destination <- io getHomeDirectory Download.aria destination uri filename -myLoadFinishedHook :: K ()-myLoadFinishedHook = History.log =<< getUserDataDir "hbro" >/> "history"+-- myLoadFinishedHook :: KE ()+myLoadFinishedHook _ = History.log -- Setup (run at start-up)--- Note that keybindings are suited for an azerty keyboard.+-- Note that keybindings are suited for an azerty keyboard mySetup :: K () mySetup = do- myHistoryFile <- getUserDataDir "hbro" >/> "history"- myBookmarksFile <- getUserDataDir "hbro" >/> "bookmarks"+ Config.set homePageL myHomePage+ WebView.set onDownloadL myDownloadHook+ WebView.set onLoadFinishedL myLoadFinishedHook -- Browse- bind Key.Normal "C-<Left>" $ goBackList ["-l", "10"] >>= load- bind Key.Normal "C-<Right>" $ goForwardList ["-l", "10"] >>= load- bind Key.Normal "C-g" $ Prompt.read "DuckDuckGo search" "" (load <=< parseURIReference . ("http://duckduckgo.com/html?q=" ++) . escapeURIString isAllowedInURI)+ Key.bind (_Control .| _Left) $ goBackList ["-l", "10"] >>= load+ Key.bind (_Control .| _Right) $ goForwardList ["-l", "10"] >>= load+ Key.bind (_Control .| _g) $ prompt "DuckDuckGo search" "" >>= parseURIReference . ("http://duckduckgo.com/html?q=" ++) . (pack . escapeURIString isAllowedInURI . unpack) >>= load -- 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+ Key.bind (_Control .| _d) $ prompt "Bookmark with tags:" "" >>= Bookmarks.add . Set.fromList . words+{- Key.bind (_Control .| _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),-+ forM uris $ Bookmarks.addCustom . (`Bookmarks.Entry` words tags)+ void . Bookmarks.addCustom . (`Bookmarks.Entry` words tags) =<< getURI-}+ Key.bind (_Alt .| _d) $ Bookmarks.deleteByTag ["-l", "10"]+ Key.bind (_Control .| _l) $ Bookmarks.select ["-l", "10"] >>= load+ Key.bind (_Control .| _L) $ Bookmarks.selectByTag ["-l", "10"] >>= void . mapM (\uri -> io $ spawn "hbro" ["-u", show uri]) -- History- bind Key.Normal "C-h" $ History.select myHistoryFile ["-l", "10"] >>= load . History.mURI--- Session- --("M-l"), loadFromSession ["-l", "10"])+ Key.bind (_Alt .| _h) $ load . History._uri =<< History.select ["-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"))+ Key.bind (_Alt .| _j) $ WebSettings.toggle_ webSettingsEnableScripts+ Key.bind (_Alt .| _p) $ WebSettings.toggle_ webSettingsEnablePlugins -- 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+ WebSettings.set webSettingsEnablePlugins False+ WebSettings.set webSettingsEnableScripts True+ WebSettings.set webSettingsJSCanOpenWindowAuto True+ WebSettings.set webSettingsUserAgent firefoxUserAgent --- Favicon- --_ <- on webView iconLoaded $ \uri -> do something+-- Status bar customization: scroll position + zoom level + load progress + current URI + key strokes+ installScrollWidget =<< GUI.getObject castToLabel "scroll"+ installZoomWidget =<< GUI.getObject castToLabel "zoom"+ installProgressWidget =<< GUI.getObject castToLabel "progress"+ installURIWidget defaultURIColors defaultSecureURIColors =<< GUI.getObject castToLabel "uri"+ installKeyStrokesWidget =<< GUI.getObject castToLabel "keys" return ()---myConfig :: Config K -> Config K-myConfig = id- . set homePage myHomePage- . set onDownload myDownloadHook- . set onLoadFinished myLoadFinishedHook -- Main function, expected to call 'hbro'
examples/ui.xml view
@@ -1,21 +1,27 @@ <interface> <object class="GtkWindow" id="mainWindow">+ <property name="default-height">768</property>+ <property name="default-width">1024</property>+ <child><object class="GtkVBox" id="windowBox"> <property name="homogeneous">False</property> <property name="spacing">0</property> <!-- Scrolled window, will contain the webview --> <child>- <object class="GtkScrolledWindow" id="webViewParent"></object>+ <object class="GtkScrolledWindow" id="webViewParent">+ <property name="hscrollbar-policy">GTK_POLICY_NEVER</property>+ <property name="vscrollbar-policy">GTK_POLICY_NEVER</property>+ </object> </child>- + <!-- Prompt bar --> <child> <object class="GtkHBox" id="promptBox"> <property name="homogeneous">False</property> <property name="spacing">10</property>- + <child> <object class="GtkLabel" id="promptDescription"></object> <packing>@@ -39,7 +45,7 @@ <object class="GtkHBox" id="statusBox"> <property name="homogeneous">False</property> <property name="spacing">5</property>- + <child> <object class="GtkLabel" id="progress"></object> <packing>@@ -91,7 +97,7 @@ <property name="expand">False</property> </packing> </child>- + </object> <packing>@@ -106,7 +112,7 @@ <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>
hbro-contrib.cabal view
@@ -1,15 +1,15 @@ Name: hbro-contrib-Version: 1.1.1.0+Version: 1.2.0.0 Synopsis: Third-party extensions to hbro.--- Description:-Homepage: https://github.com/k0ral/hbro-contrib/+Description: Cf README+Homepage: https://bitbucket.org/k0ral/hbro-contrib Category: Browser,Web License: OtherLicense License-file: LICENSE -- Copyright:-Author: koral-Maintainer: koral at mailoo dot org+Author: koral <koral at mailoo dot org>+Maintainer: koral <koral at mailoo dot org> Cabal-version: >=1.8 Build-type: Simple@@ -18,29 +18,37 @@ Source-repository head Type: git- Location: git@github.com:k0ral/hbro-contrib.git+ Location: https://github.com/k0ral/hbro-contrib.git+Source-repository head+ Type: hg+ Location: https://bitbucket.org/k0ral/hbro-contrib+Source-repository head+ Type: hg+ Location: http://hgweb.twyk.org/hbro-contrib Library Build-depends: base == 4.*,- directory,- filepath,+ classy-prelude,+ containers, glib,- gtk >= 0.12.3,- hbro >= 1.1.1.0,+ gtk3 >= 0.12.3,+ hbro >= 1.2.0.0, monad-control,- mtl,- network,- old-locale,+ mtl >= 2.2.1,+ network-uri, pango,+ parsec, process, -- random-extras, -- random-fu,+ safe,+ system-fileio, text, time, transformers-base, unix,- webkit+ webkitgtk3 Exposed-modules: Hbro.Bookmarks, Hbro.Download,@@ -50,9 +58,12 @@ Hbro.StatusBar Extensions: ConstraintKinds,+ DeriveDataTypeable, FlexibleContexts, FunctionalDependencies, GeneralizedNewtypeDeriving, MultiParamTypeClasses,+ NoImplicitPrelude,+ OverloadedStrings, RankNTypes- Ghc-options: -Wall+ Ghc-options: -Wall -fno-warn-unused-do-bind -threaded