diff --git a/Hbro/Bookmarks.hs b/Hbro/Bookmarks.hs --- a/Hbro/Bookmarks.hs +++ b/Hbro/Bookmarks.hs @@ -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 diff --git a/Hbro/Clipboard.hs b/Hbro/Clipboard.hs deleted file mode 100644 --- a/Hbro/Clipboard.hs +++ /dev/null @@ -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) diff --git a/Hbro/Download.hs b/Hbro/Download.hs --- a/Hbro/Download.hs +++ b/Hbro/Download.hs @@ -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] diff --git a/Hbro/History.hs b/Hbro/History.hs --- a/Hbro/History.hs +++ b/Hbro/History.hs @@ -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) diff --git a/Hbro/Misc.hs b/Hbro/Misc.hs --- a/Hbro/Misc.hs +++ b/Hbro/Misc.hs @@ -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) diff --git a/Hbro/Settings.hs b/Hbro/Settings.hs new file mode 100644 --- /dev/null +++ b/Hbro/Settings.hs @@ -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" +-- }}} diff --git a/Hbro/StatusBar.hs b/Hbro/StatusBar.hs --- a/Hbro/StatusBar.hs +++ b/Hbro/StatusBar.hs @@ -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 () diff --git a/Hbro/WebSettings.hs b/Hbro/WebSettings.hs deleted file mode 100644 --- a/Hbro/WebSettings.hs +++ /dev/null @@ -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" --- }}} diff --git a/examples/hbro.hs b/examples/hbro.hs --- a/examples/hbro.hs +++ b/examples/hbro.hs @@ -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-", goBackList ["-l", "10"] >>= mapM_ loadURI), - ("C-", 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-", goBackList ["-l", "10"] >>= loadURI), + ("C-", 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 () --- }}} diff --git a/hbro-contrib.cabal b/hbro-contrib.cabal --- a/hbro-contrib.cabal +++ b/hbro-contrib.cabal @@ -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