diff --git a/Hbro/Bookmarks.hs b/Hbro/Bookmarks.hs --- a/Hbro/Bookmarks.hs +++ b/Hbro/Bookmarks.hs @@ -11,12 +11,15 @@ -- {{{ Imports import Hbro +-- import Hbro.Error +import Hbro.Gui import Hbro.Misc +import Hbro.Network import Control.Exception import Control.Monad hiding(forM_, mapM_) +import Control.Monad.Base import Control.Monad.Error hiding(forM_, mapM_) -import Control.Monad.Reader hiding(forM_, mapM_) --import qualified Data.ByteString.Char8 as B -- import Data.Foldable hiding(find, foldr) @@ -30,7 +33,7 @@ import Network.URI (URI) -import Prelude hiding(catch, mapM_) +import Prelude hiding(mapM_) import System.IO -- }}} @@ -40,7 +43,7 @@ mURI :: URI, mTags :: [String] } - + instance Show Entry where show (Entry uri tags) = unwords $ (show uri):tags -- }}} @@ -57,28 +60,27 @@ hasTag tag = isJust . (find $ (==) tag) . mTags -- | Add current webpage to bookmarks with given tags -add :: (Functor m, MonadIO m, MonadReader r m, HasWebView r, MonadError HError m) => IO FilePath -> [String] -> m () +add :: (Functor m, MonadBase IO m, GUIReader n m, MonadError HError m) => FilePath -> [String] -> m () add file tags = do uri <- getURI void . addCustom file $ Entry uri tags -- | Add a custom entry to bookmarks -addCustom :: (MonadIO m, MonadError HError m) - => IO FilePath -- ^ Bookmarks' database file +addCustom :: (MonadBase IO m, MonadError HError m) + => FilePath -- ^ Bookmarks' database file -> Entry -- ^ New bookmarks entry -> m () addCustom file newEntry = do - file' <- io file - either (throwError . IOE) return =<< (io . try $ withFile file' AppendMode (`hPutStrLn` show newEntry)) + either (throwError . IOE) return =<< (io . try $ withFile file AppendMode (`hPutStrLn` show newEntry)) --either (\e -> errorHandler file' e >> return False) (const $ return True) result -- | Open a dmenu with all (sorted alphabetically) bookmarks entries, and return the user's selection, if any. -select :: (Functor m, MonadIO m, MonadError HError m) - => IO FilePath -- ^ Bookmarks' database file +select :: (Functor m, MonadBase IO m, MonadError HError m) + => FilePath -- ^ Bookmarks' database file -> [String] -- ^ dmenu's commandline options -> m URI select file dmenuOptions = do - result <- either (throwError . IOE) return =<< (io . try $ readFile =<< file) + 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) @@ -90,14 +92,13 @@ tags' = sort $ map (\tag -> '[':(tag ++ "]")) tags -- | Open a dmenu with all (sorted alphabetically) bookmarks tags, and return the user's selection, if any. -selectTag :: (Functor m, MonadIO m, MonadError HError m) - => IO FilePath -- ^ Bookmarks' database file +selectTag :: (Functor m, MonadBase IO m, MonadError HError m) + => FilePath -- ^ Bookmarks' database file -> [String] -- ^ dmenu's commandline options -> m [URI] selectTag file dmenuOptions = do -- Read bookmarks file - file' <- io file - result <- either (throwError . IOE) return =<< (io . try $ readFile 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 @@ -106,11 +107,11 @@ -- Let user select a tag (map mURI) . (\t -> filter (hasTag t) entries) <$> dmenu dmenuOptions tags --- | +-- --popOldest :: PortableFilePath -> String -> IO (Maybe URI) --popOldest file tags = do --- | Return a random Bookmark entry with a given tag, while removing it from bookmarks. +-- Return a random Bookmark entry with a given tag, while removing it from bookmarks. -- popRandom :: PortableFilePath -- -> String -- -> IO (Maybe URI) @@ -131,18 +132,17 @@ -- | Remove all bookmarks entries matching the given tag. -deleteWithTag :: (Functor m, MonadIO m, MonadError HError m) - => IO FilePath -- ^ Bookmarks' database file +deleteWithTag :: (Functor m, MonadBase IO m, MonadError HError m) + => FilePath -- ^ Bookmarks' database file -> [String] -- ^ dmenu's commandline options -> m () deleteWithTag file dmenuOptions = do - file' <- io file - result <- either (throwError . IOE) return =<< (io . try $ readFile 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 tag <- dmenu dmenuOptions tags - io $ writeFile (file' ++ ".old") $ unlines (map show entries) - io $ writeFile file' $ (unlines . (map show) . (filter (not . (hasTag tag)))) entries + io $ writeFile (file ++ ".old") $ unlines (map show entries) + io $ writeFile file $ (unlines . (map show) . (filter (not . (hasTag tag)))) entries diff --git a/Hbro/Download.hs b/Hbro/Download.hs --- a/Hbro/Download.hs +++ b/Hbro/Download.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE FlexibleContexts #-} module Hbro.Download where -- {{{ Imports import Hbro.Util -import Control.Monad.IO.Class +import Control.Monad.Base import Network.URI @@ -11,7 +12,7 @@ -- }}} -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] +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] diff --git a/Hbro/History.hs b/Hbro/History.hs --- a/Hbro/History.hs +++ b/Hbro/History.hs @@ -9,13 +9,15 @@ ) where -- {{{ Imports -import Hbro +import Hbro hiding(log) +-- import Hbro.Error +import Hbro.Gui import Hbro.Misc +import Hbro.Network import Control.Exception +import Control.Monad.Base import Control.Monad.Error --- import Control.Monad.IO.Class -import Control.Monad.Reader import Data.Functor import Data.List @@ -33,7 +35,7 @@ -- {{{ Type definitions data Entry = Entry { mTime :: LocalTime, - mURI :: URI, + mURI :: URI, mTitle :: String } @@ -45,7 +47,7 @@ -- }}} -- | Log current visited page to history file -log :: (MonadIO m, MonadReader r m, HasWebView r, MonadError HError m) => IO FilePath -> m () +log :: (MonadBase IO m, ConfigReader n m, GUIReader n m, MonadError HError m) => FilePath -> m () log file = do uri <- getURI title <- getTitle @@ -55,13 +57,13 @@ add file (Entry now uri title) -- | Add a new entry to history file -add :: (MonadIO m, MonadError HError m) - => IO FilePath -- ^ 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 - file' <- io file - either (throwError . IOE) return =<< (io . try $ withFile file' AppendMode (`hPutStrLn` show newEntry)) + logV $ "Adding new history entry <" ++ show (mURI newEntry) ++ ">" + either (throwError . IOE) return =<< (io . try $ withFile file AppendMode (`hPutStrLn` show newEntry)) --either (\e -> errorHandler file' e >> return False) (const $ return True) result -- | Try to parse a String into a history Entry. @@ -78,11 +80,10 @@ parseEntry' _ = throwError $ OtherError "While parsing history entry: invalid format." -- | Open a dmenu with all (sorted alphabetically) history entries, and return the user's selection, if any -select :: (Functor m, MonadIO m, MonadError HError m) - => IO FilePath -- ^ Path to history file +select :: (Functor m, MonadBase IO m, MonadError HError m) + => FilePath -- ^ Path to history file -> [String] -- ^ dmenu's commandline options -> m Entry -- ^ Selected history entry, if any select file dmenuOptions = do - --either (\e -> errorHandler file' e >> return Nothing) (return . return) result - parseEntry =<< dmenu dmenuOptions . unlines . reverse . sort . nub . lines =<< either (throwError . IOE) return =<< (io . try $ readFile =<< file) + 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 @@ -3,11 +3,13 @@ -- {{{ Imports import Hbro +-- import Hbro.Error +import Hbro.Gui +import Hbro.Network import Control.Exception +import Control.Monad.Base import Control.Monad.Error --- import Control.Monad.IO.Class -import Control.Monad.Reader -- import Data.Functor import Data.Maybe @@ -25,7 +27,7 @@ -- | Open dmenu with given input and return selected entry. -dmenu :: (Functor m, MonadIO m, MonadError HError m) +dmenu :: (Functor m, MonadBase IO m, MonadError HError m) => [String] -- ^ dmenu's commandline options -> String -- ^ dmenu's input -> m String -- ^ Selected entry @@ -41,9 +43,9 @@ -- | List preceding URIs in dmenu and let the user select which one to load. -goBackList :: (Functor m, MonadIO m, MonadReader r m, HasWebView r, MonadError HError m) => [String] -> m URI +goBackList :: (Functor m, MonadBase IO m, GUIReader n m, MonadError HError m) => [String] -> m URI goBackList dmenuOptions = do - list <- io . webViewGetBackForwardList =<< asks _webview + list <- io . webViewGetBackForwardList =<< readGUI webView n <- io $ webBackForwardListGetBackLength list backList <- io $ webBackForwardListGetBackListWithLimit list n dmenuList <- io $ mapM itemToEntry backList @@ -52,9 +54,9 @@ -- | List succeeding URIs in dmenu and let the user select which one to load. -goForwardList :: (Functor m, MonadIO m, MonadReader r m, HasWebView r, MonadError HError m) => [String] -> m URI +goForwardList :: (Functor m, MonadBase IO m, GUIReader n m, MonadError HError m) => [String] -> m URI goForwardList dmenuOptions = do - list <- io . webViewGetBackForwardList =<< asks _webview + list <- io . webViewGetBackForwardList =<< readGUI webView n <- io $ webBackForwardListGetForwardLength list forwardList <- io $ webBackForwardListGetForwardListWithLimit list n dmenuList <- io $ mapM itemToEntry forwardList diff --git a/Hbro/Session.hs b/Hbro/Session.hs deleted file mode 100644 --- a/Hbro/Session.hs +++ /dev/null @@ -1,60 +0,0 @@ -module Hbro.Session where - --- {{{ Imports ---import Hbro.Types --- import Hbro.Util - --- import Data.Foldable --- import qualified Data.Text as T --- import qualified Data.Text.IO as T - --- import Graphics.UI.Gtk.General.General --- import Graphics.UI.Gtk.WebKit.WebView hiding(webViewGetUri) - --- import Prelude hiding(mapM_) - --- import System.Directory --- import System.Environment --- import System.Glib.Signals --- import System.IO --- import System.Posix.Process --- import System.Process --- }}} - ---setupSession :: WebView -> String -> IO () ---setupSession webView sessionDirectory = do --- pid <- getProcessID --- previousSession <- getDirectoryContents sessionDirectory --- --- let sessionFile = sessionDirectory ++ show pid --- --- _ <- on webView loadFinished $ \_ -> do --- webViewGetUri webView >>= mapM_ ((writeFile sessionFile) . show) --- --- _ <- quitAdd 0 $ do --- removeFile sessionFile --- return False --- --- return () - - ---loadFromSession :: [String] -> String -> IO () ---loadFromSession dmenuOptions sessionDirectory = do --- previousSession <- getDirectoryContents sessionDirectory --- sessionURIs <- mapM getSessionURI previousSession --- --- selection <- dmenu dmenuOptions (T.unlines sessionURIs) --- --- case selection of --- "" -> return () --- u -> do --- _ <- spawn "hbro" ["-u", u] --- return () --- ---getSessionURI :: String -> IO T.Text ---getSessionURI fileName = do --- configHome <- getEnv "XDG_CONFIG_HOME" --- file <- T.readFile $ configHome ++ "/hbro/sessions/" ++ fileName --- --- return $ (head . T.lines) file - diff --git a/Hbro/StatusBar.hs b/Hbro/StatusBar.hs --- a/Hbro/StatusBar.hs +++ b/Hbro/StatusBar.hs @@ -1,15 +1,15 @@ +{-# LANGUAGE FlexibleContexts #-} module Hbro.StatusBar where -- {{{ Imports --- import Hbro.Core ---import Hbro.Keys +import Hbro.Config +import Hbro.Keys as Key import Hbro.Gui -import Hbro.Types -import Hbro.Util +import Hbro.Util import Control.Monad hiding(forM_, mapM_) -import Control.Monad.IO.Class -import Control.Monad.Reader hiding(forM_, mapM_) +import Control.Monad.Base +-- import Control.Monad.Reader hiding(forM_, mapM_) import Data.Foldable import Data.List @@ -32,104 +32,93 @@ -- }}} --- notify :: Environment -> String -> Color -> IO () --- notify env text color = do --- 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 :: (MonadIO m, MonadReader r m, HasScrollWindow r) => Label -> m () +setupScrollWidget :: (MonadBase IO m, GUIReader n m) => Label -> m () setupScrollWidget widget = do - adjustment <- io . scrolledWindowGetVAdjustment =<< asks _scrollwindow + adjustment <- io . scrolledWindowGetVAdjustment =<< readGUI scrollWindow io $ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 32767 32767 32767}] - - _ <- io $ onValueChanged adjustment $ do + + io . void . onValueChanged adjustment $ do current <- adjustmentGetValue adjustment lower <- adjustmentGetLower adjustment upper <- adjustmentGetUpper adjustment page <- adjustmentGetPageSize adjustment - + case upper-lower-page of 0 -> labelSetText widget "ALL" x -> labelSetText widget $ show (round $ current/x*100) ++ "%" - + io $ labelSetText widget "0%" --- | /!\ Doesn't work for now. +-- | /!\\ Doesn't work for now. -- Write current zoom level in the given Label. -setupZoomWidget :: (MonadIO m, MonadReader r m, HasWebView r) => Label -> m () +setupZoomWidget :: (MonadBase IO m, GUIReader n m) => Label -> m () setupZoomWidget widget = do - io $ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 65535 65535}] - asks _webview >>= io . webViewGetZoomLevel >>= io . labelSetMarkup widget . escapeMarkup . show - --- | -printInLabel :: (MonadIO m, MonadReader r m, HasGUI r) => String -> (String, Bool) -> m (String, Bool) -printInLabel label (keystrokes, match) = do - widget <- getObject castToLabel label + io $ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 65535 65535}] + readGUI webView >>= io . webViewGetZoomLevel >>= io . labelSetMarkup widget . escapeMarkup . show + +-- | Write current keystrokes state in the given 'Label' +setupKeyStrokesWidget :: (MonadBase IO m, ConfigWriter m m, GUIReader m m) => Label -> m () +setupKeyStrokesWidget widget = do io $ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 65535 0}] - io $ case match of - True -> labelSetText widget [] - _ -> labelSetText widget keystrokes - - return (keystrokes, match) --- | Write current load progress in the given Label. -setupProgressWidget :: (MonadIO m, MonadReader r m, HasWebView r) => Label -> m () + writeConfig onKeyStroke $ io . labelSetText widget . intercalate " " . map Key.serialize + +-- | Write current load progress in the given 'Label'. +setupProgressWidget :: (MonadBase IO m, GUIReader n m) => Label -> m () setupProgressWidget widget = do - webView <- asks _webview + wv <- readGUI webView -- Load started - _ <- io $ on webView loadStarted $ \_ -> do + io . void . on wv loadStarted $ \_ -> do labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0}] labelSetText widget "0%" --- Progress changed - _ <- io $ on webView progressChanged $ \progress' -> do +-- Progress changed + io . void . on wv progressChanged $ \progress' -> do labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 65535 0}] labelSetText widget $ show progress' ++ "%" -- Load finished - _ <- io $ on webView loadFinished $ \_ -> do + io . void . on wv loadFinished $ \_ -> do labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 0 65535 0}] labelSetText widget "100%" -- Error - _ <- io $ on webView loadError $ \_ _ _ -> do + io . void . on wv loadError $ \_ _ _ -> do labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0}] labelSetText widget "ERROR" return False - + return () -- | Write current URI, or the destination of a hovered link, in the given Label. -setupURIWidget :: (MonadIO m, MonadReader r m, HasWebView r) => URIColors -> URIColors -> Label -> m () +setupURIWidget :: (MonadBase IO m, GUIReader n m) => URIColors -> URIColors -> Label -> m () setupURIWidget normalColors secureColors widget = do - webView <- asks _webview + wv <- readGUI webView -- URI changed - _ <- io $ on webView loadCommitted $ \_ -> - (mapM_ (labelSetURI normalColors secureColors widget)) =<< ((>>= N.parseURIReference) `fmap` (webViewGetUri webView)) + _ <- io $ on wv loadCommitted $ \_ -> + (mapM_ (labelSetURI normalColors secureColors widget)) =<< ((>>= N.parseURIReference) `fmap` (webViewGetUri wv)) -- Link (un)hovered - _ <- io $ on webView hoveringOverLink $ \_title hoveredURI -> do - uri <- webViewGetUri webView - + _ <- io $ on wv hoveringOverLink $ \_title hoveredURI -> do + uri <- webViewGetUri wv + forM_ (hoveredURI >>= N.parseURIReference) $ labelSetURI normalColors secureColors widget unless (isJust hoveredURI) $ forM_ (uri >>= N.parseURIReference) (labelSetURI normalColors secureColors widget) - + return () --- | +-- | labelSetURI :: URIColors -> URIColors -> Label -> URI -> IO () labelSetURI normalColors secureColors widget uri = do let colors = case uriScheme uri of "https:" -> secureColors _ -> normalColors - + let i:j:k:l:_ = map length [ uriScheme uri, maybe [] uriRegName (uriAuthority uri), uriPath uri, uriQuery uri] - + labelSetAttributes widget $ [ AttrWeight{ paStart = 0, paEnd = -1, paWeight = WeightBold }, AttrForeground{ paStart = 0, paEnd = i+2, paColor = mScheme colors }, @@ -137,10 +126,10 @@ AttrForeground{ paStart = i+2+j, paEnd = i+2+j+k, paColor = mPath colors }, AttrForeground{ paStart = i+2+j+k, paEnd = i+2+j+k+l, paColor = mQuery colors }, AttrForeground{ paStart = i+2+j+k+l, paEnd = -1, paColor = mFragment colors }] - + labelSetText widget (show uri) - - + + data URIColors = URIColors { mScheme :: Color, mHost :: Color, diff --git a/examples/hbro.hs b/examples/hbro.hs --- a/examples/hbro.hs +++ b/examples/hbro.hs @@ -6,150 +6,101 @@ import qualified Hbro.Bookmarks as Bookmarks import qualified Hbro.Clipboard as Clipboard import qualified Hbro.Download as Download +import qualified Hbro.Gui as GUI import qualified Hbro.History as History +import Hbro.Keys as Key import Hbro.Misc +import Hbro.Network +import Hbro.Notification import qualified Hbro.Prompt as Prompt -import Hbro.Session +-- import Hbro.Session import Hbro.Settings import Hbro.StatusBar import qualified Hbro.Webkit.WebSettings as WS import Control.Conditional +import Control.Lens hiding((??)) import Control.Monad hiding(forM_, mapM_) -import 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 -import Graphics.UI.Gtk.Builder import Graphics.UI.Gtk.Display.Label -import Graphics.UI.Gtk.Entry.Entry -import Graphics.UI.Gtk.Gdk.EventM -import Graphics.UI.Gtk.Gdk.GC -import Graphics.UI.Gtk.General.General -import Graphics.UI.Gtk.WebKit.Download -import Graphics.UI.Gtk.WebKit.NetworkRequest -import Graphics.UI.Gtk.WebKit.WebNavigationAction import Graphics.UI.Gtk.WebKit.WebSettings -import Graphics.UI.Gtk.Windows.Window import Network.URI hiding(parseURI, parseURIReference) import Prelude hiding(mapM_) import System.Directory -import System.Environment import System.Environment.XDG.BaseDir import System.FilePath -import System.Glib.Attributes -import System.Glib.Signals --- import System.Posix.Process -import System.Process -- }}} --- {{{ Configuration structures --- Any field you don't override will use the defaults defined in Hbro.Types.Config. -myConfig :: Config -myConfig = def { - __UIFile = myUIFile, - __homePage = myHomePage} --- }}} --- {{{ Constant parameters -myHomePage = URI "https:" (Just $ URIAuth "" "//duckduckgo.com" "") "" "" "" +myHomePage = URI "http:" (Just $ URIAuth "" "//www.google.com" "") "" "" "" -- Seriously ? -myUIFile, myHistoryFile, myBookmarksFile, myDownloadDirectory :: IO FilePath -myUIFile = getUserConfigDir "hbro" >/> "ui.xml" -myHistoryFile = getUserDataDir "hbro" >/> "history" -myBookmarksFile = getUserDataDir "hbro" >/> "bookmarks" -myDownloadDirectory = getHomeDirectory --- }}} +-- Download to $HOME +myDownloadHook :: URI -> String -> Int -> K () +myDownloadHook uri filename _size = do + destination <- io getHomeDirectory + Download.aria destination uri filename --- {{{ Keys --- Note that this example is suited for an azerty keyboard. -myKeys :: KeysList -myKeys = def <> KeysList [ +myLoadFinishedHook :: K () +myLoadFinishedHook = History.log =<< getUserDataDir "hbro" >/> "history" + +-- Setup (run at start-up) +-- Note that keybindings are suited for an azerty keyboard. +mySetup :: K () +mySetup = do + myHistoryFile <- getUserDataDir "hbro" >/> "history" + myBookmarksFile <- getUserDataDir "hbro" >/> "bookmarks" + -- Browse - ("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)), + bind Key.Normal "C-" $ goBackList ["-l", "10"] >>= load + bind Key.Normal "C-" $ goForwardList ["-l", "10"] >>= load + bind Key.Normal "C-g" $ Prompt.read "DuckDuckGo search" "" (load <=< parseURIReference . ("http://duckduckgo.com/html?q=" ++) . escapeURIString isAllowedInURI) -- Bookmarks - ("C-d", Prompt.read "Bookmark with tags:" "" $ Bookmarks.add myBookmarksFile . words), - ("C-D", Prompt.read "Bookmark all instances with tag:" "" $ \tags -> do + bind Key.Normal "C-d" $ Prompt.read "Bookmark with tags:" "" $ Bookmarks.add myBookmarksFile . words +{- bind Key.Normal "C-D" $ Prompt.read "Bookmark all instances with tag:" "" $ \tags -> do uris <- mapM parseURI =<< sendCommandToAll "GET_URI" forM uris $ Bookmarks.addCustom myBookmarksFile . (`Bookmarks.Entry` words tags) - void . Bookmarks.addCustom myBookmarksFile . (`Bookmarks.Entry` words tags) =<< getURI - ), - ("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)])), + 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 --- loadURI uri b), +-- load uri b), -- History - ("C-h", History.select myHistoryFile ["-l", "10"] >>= loadURI . History.mURI), - + bind Key.Normal "C-h" $ History.select myHistoryFile ["-l", "10"] >>= load . 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"))) - ] --- }}} - -myDownloadHook :: DownloadHook -myDownloadHook = DownloadHook $ \uri filename _size -> Download.aria myDownloadDirectory uri filename - -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 + bind Key.Normal "M-j" $ WS.toggle webSettingsEnableScripts >>= ((notify 5000 "Javascript disabled") ?? (notify 5000 "Javascript enabled")) + bind Key.Normal "M-p" $ WS.toggle webSettingsEnablePlugins >>= ((notify 5000 "Plugins disabled") ?? (notify 5000 "Plugins enabled")) -- Web settings (cf Graphic.Gtk.WebKit.WebSettings) - WS.modify 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" + setupScrollWidget =<< GUI.getObject castToLabel "scroll" -- Zoom level in status bar - setupZoomWidget =<< getObject castToLabel "zoom" + setupZoomWidget =<< GUI.getObject castToLabel "zoom" -- Load progress in status bar - setupProgressWidget =<< getObject castToLabel "progress" + setupProgressWidget =<< GUI.getObject castToLabel "progress" -- Current URI in status bar - setupURIWidget defaultURIColors defaultSecureURIColors =<< getObject castToLabel "uri" + setupURIWidget defaultURIColors defaultSecureURIColors =<< GUI.getObject castToLabel "uri" +-- Keystrokes in status bar + setupKeyStrokesWidget =<< GUI.getObject castToLabel "keys" + -- Session manager --setupSession browser @@ -157,3 +108,18 @@ --_ <- on webView iconLoaded $ \uri -> do something return () + + +myConfig :: FilePath -> Config K -> Config K +myConfig myUIFile = id + . set uIFile myUIFile + . set homePage myHomePage + . set onDownload myDownloadHook + . set onLoadFinished myLoadFinishedHook + + +-- Main function, expected to call 'hbro' +main :: IO () +main = do + myUIFile <- getUserConfigDir "hbro" >/> "ui.xml" + hbro mySetup $ myConfig myUIFile diff --git a/hbro-contrib.cabal b/hbro-contrib.cabal --- a/hbro-contrib.cabal +++ b/hbro-contrib.cabal @@ -1,5 +1,5 @@ Name: hbro-contrib -Version: 1.0.0.0 +Version: 1.1.0.0 Synopsis: Third-party extensions to hbro. -- Description: Homepage: https://github.com/k0ral/hbro-contrib/ @@ -38,7 +38,7 @@ -- random-fu, text, time, - transformers, + transformers-base, unix, webkit Exposed-modules: @@ -46,7 +46,6 @@ Hbro.Download, Hbro.History, Hbro.Misc, - Hbro.Session, Hbro.Settings, Hbro.StatusBar Ghc-options: -Wall