diff --git a/Hbro/Bookmarks.hs b/Hbro/Bookmarks.hs --- a/Hbro/Bookmarks.hs +++ b/Hbro/Bookmarks.hs @@ -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 diff --git a/Hbro/Download.hs b/Hbro/Download.hs --- a/Hbro/Download.hs +++ b/Hbro/Download.hs @@ -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)] diff --git a/Hbro/History.hs b/Hbro/History.hs --- a/Hbro/History.hs +++ b/Hbro/History.hs @@ -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 diff --git a/Hbro/Misc.hs b/Hbro/Misc.hs --- a/Hbro/Misc.hs +++ b/Hbro/Misc.hs @@ -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 diff --git a/Hbro/Settings.hs b/Hbro/Settings.hs --- a/Hbro/Settings.hs +++ b/Hbro/Settings.hs @@ -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" diff --git a/Hbro/StatusBar.hs b/Hbro/StatusBar.hs --- a/Hbro/StatusBar.hs +++ b/Hbro/StatusBar.hs @@ -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)) diff --git a/examples/hbro.hs b/examples/hbro.hs --- a/examples/hbro.hs +++ b/examples/hbro.hs @@ -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-" $ 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) + 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' diff --git a/examples/ui.xml b/examples/ui.xml --- a/examples/ui.xml +++ b/examples/ui.xml @@ -1,21 +1,27 @@ + 768 + 1024 + False 0 - + + GTK_POLICY_NEVER + GTK_POLICY_NEVER + - + False 10 - + @@ -39,7 +45,7 @@ False 5 - + @@ -91,7 +97,7 @@ False - + @@ -106,7 +112,7 @@ False 5 - + True diff --git a/hbro-contrib.cabal b/hbro-contrib.cabal --- a/hbro-contrib.cabal +++ b/hbro-contrib.cabal @@ -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 +Maintainer: koral 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