diff --git a/Hbro/Bookmarks.hs b/Hbro/Bookmarks.hs --- a/Hbro/Bookmarks.hs +++ b/Hbro/Bookmarks.hs @@ -1,15 +1,16 @@ module Hbro.Bookmarks ( Entry(..), add, + addCustom, select, selectTag, deleteWithTag ) where -- {{{ Imports ---import Hbro.Core +import Hbro.Core --import Hbro.Gui ---import Hbro.Types +import Hbro.Types hiding(mURI) import Hbro.Util import Control.Exception @@ -17,9 +18,14 @@ --import qualified Data.ByteString.Char8 as B import Data.Foldable hiding(find, foldr) +import Data.Functor import Data.List import Data.Maybe +-- import Data.Random.Extras +-- import Data.Random.RVar +-- import Data.Random.Source.DevRandom + import Network.URI import Prelude hiding(catch, mapM_) @@ -49,27 +55,32 @@ hasTag :: String -> Entry -> Bool hasTag tag = isJust . (find $ (==) tag) . mTags --- | Add a new entry to the bookmarks' database (which is a file). -add :: FilePath -- ^ Bookmarks' database file - -> Entry -- ^ New bookmarks entry - -> IO Bool -add bookmarksFile newEntry = do - result <- try $ withFile bookmarksFile AppendMode (flip hPutStrLn (show newEntry)) - either (\e -> errorHandler bookmarksFile e >> return False) (const $ return True) result +-- | 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 a custom entry to bookmarks +addCustom :: PortableFilePath -- ^ Bookmarks' database file + -> Entry -- ^ New bookmarks entry + -> IO Bool +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 -- | Open a dmenu with all (sorted alphabetically) bookmarks entries, and return the user's selection, if any. -select :: FilePath -- ^ Bookmarks' database file - -> [String] -- ^ dmenu's commandline options - -> IO (Maybe String) -select bookmarksFile dmenuOptions = do - result <- try $ readFile bookmarksFile +select :: PortableFilePath -- ^ Bookmarks' database file + -> [String] -- ^ dmenu's commandline options + -> IO (Maybe URI) +select file dmenuOptions = do + file' <- resolve file + result <- try $ readFile file' - either (\e -> errorHandler bookmarksFile e >> return Nothing) (\x -> return $ Just x) result + 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 . ((return . last. words) =<<)) + >>= (return . ((parseURIReference . last . words) =<<)) - reformat :: String -> String reformat line = unwords $ tags' ++ [uri] where @@ -77,36 +88,61 @@ tags' = sort $ map (\tag -> '[':(tag ++ "]")) tags -- | Open a dmenu with all (sorted alphabetically) bookmarks tags, and return the user's selection, if any. -selectTag :: FilePath -- ^ Bookmarks' database file +selectTag :: PortableFilePath -- ^ Bookmarks' database file -> [String] -- ^ dmenu's commandline options -> IO (Maybe [URI]) -selectTag bookmarksFile dmenuOptions = do - -- Read bookmarks file - result <- try $ readFile bookmarksFile - file <- either (\e -> errorHandler bookmarksFile e >> return Nothing) (\x -> return $ Just x) result +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 = (return . catMaybes . (map parseEntry) . lines) =<< file - let tags = (return . unlines . sort . nub . words . unwords . (foldr (union . mTags) [])) =<< entries + let entries = (catMaybes . map parseEntry . lines) <$> file'' + let tags = (unlines . sort . nub . words . unwords . (foldr (union . mTags) [])) <$> entries - -- Let user select a tag +-- Let user select a tag tag <- (maybe (return Nothing) (dmenu dmenuOptions) tags) return $ (return . (map mURI) . (\t -> filter (hasTag t) (maybe [] id entries))) =<< tag +-- | +--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 +-- -> 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 +-- (newLines, value) <- runRVar s DevURandom + +-- renameFile file' (file' ++ ".old") +-- writeFile file' . unlines . nub $ newLines +-- return . parseURIReference . last . words $ value + + -- | Remove all bookmarks entries matching the given tag. -deleteWithTag :: FilePath -- ^ Bookmarks' database file - -> [String] -- ^ dmenu's commandline options +deleteWithTag :: PortableFilePath -- ^ Bookmarks' database file + -> [String] -- ^ dmenu's commandline options -> IO () -deleteWithTag bookmarksFile dmenuOptions = do - result <- try $ readFile bookmarksFile - file <- either (\e -> errorHandler bookmarksFile e >> return Nothing) (\x -> return $ Just x) result +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 + forM_ file'' $ \f -> do let entries = (catMaybes . (map parseEntry) . lines) f let tags = (unlines . sort . nub . words . unwords . (foldr (union . mTags) [])) entries tag <- (dmenu dmenuOptions tags) forM_ tag (\t -> do - writeFile (bookmarksFile ++ ".old") $ unlines (map show entries) - writeFile bookmarksFile $ (unlines . (map show) . (filter (not . (hasTag t)))) entries + writeFile (file' ++ ".old") $ unlines (map show entries) + writeFile file' $ (unlines . (map show) . (filter (not . (hasTag t)))) entries return ()) diff --git a/Hbro/BookmarksQueue.hs b/Hbro/BookmarksQueue.hs deleted file mode 100644 --- a/Hbro/BookmarksQueue.hs +++ /dev/null @@ -1,81 +0,0 @@ -module Hbro.BookmarksQueue where - --- {{{ Imports ---import Hbro.Types - -import Data.List -import qualified Data.Text as T -import qualified Data.Text.IO as T --- }}} - - --- | Add current URI to the end of the queue. ---append :: String -> IO () ---append bookmarksFile uri = do --- configHome <- getEnv "XDG_CONFIG_HOME" --- appendFile (configHome ++ "/hbro/queue") (uri ++ "\n") - --- | Add current URI to the beginning of the queue. -push :: String -> String -> IO () -push bookmarksFile uri = do - file <- catch (T.readFile bookmarksFile) (\_error -> return T.empty) - - if (file == T.empty) - then return () - else do - let fileLines = T.lines file - let file' = T.unlines . nub $ (T.pack uri):fileLines - - T.writeFile bookmarksFile file' - - return () - --- | Return the first URI from the queue, while removing it. -popFront :: String -> IO String -popFront bookmarksFile = do - file <- catch (T.readFile bookmarksFile) (\_error -> return T.empty) - - if file == T.empty - then return "" - else do - let fileLines = T.lines file - let file' = T.unlines . tail . nub $ fileLines - - T.writeFile (bookmarksFile ++ ".old") file - T.writeFile bookmarksFile file' - - return $ T.unpack (head fileLines) - --- | Return the last URI from the queue, while removing it. -popBack :: String -> IO String -popBack bookmarksFile = do - file <- catch (T.readFile bookmarksFile) (\_error -> return T.empty) - - if file == T.empty - then return "" - else do - let fileLines = T.lines file - let file' = T.unlines . reverse . tail . reverse. nub $ fileLines - - T.writeFile (bookmarksFile ++ ".old") file - T.writeFile bookmarksFile file' - - return $ T.unpack (head $ reverse fileLines) - --- | Return a random URI from the queue, while removing it. --- popRandom :: Browser -> IO String --- popRandom browser = do --- configHome <- getEnv "XDG_CONFIG_HOME" --- file <- catch (T.readFile $ configHome ++ "/hbro/queue") (\e -> return T.empty) - --- if file == T.empty --- then return "" --- else do --- let fileLines = T.lines file --- let file' = T.unlines . reverse . tail . reverse. nub $ fileLines --- --- T.writeFile (configHome ++ "/hbro/queue.old") file --- T.writeFile (configHome ++ "/hbro/queue") file' - --- return $ T.unpack (head $ reverse fileLines) - diff --git a/Hbro/Clipboard.hs b/Hbro/Clipboard.hs --- a/Hbro/Clipboard.hs +++ b/Hbro/Clipboard.hs @@ -1,17 +1,19 @@ module Hbro.Clipboard where -- {{{ Imports ---import Hbro.Core ---import Hbro.Types ---import Hbro.Util +import Hbro.Core +import Hbro.Types +import Hbro.Util import Graphics.UI.Gtk.General.Clipboard -- }}} --- | Copy current URI in clipboard. +-- | Write given String to primary clipboard. toClipboard :: String -> IO () toClipboard text = clipboardGet selectionPrimary >>= (`clipboardSetText` text) -withClipboard :: (Maybe String -> IO ()) -> IO () -withClipboard callback = clipboardGet selectionPrimary >>= (`clipboardRequestText` callback) +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 @@ -4,20 +4,13 @@ import Hbro.Types import Hbro.Util -import Graphics.UI.Gtk.Builder -import Graphics.UI.Gtk.Display.Label - import Network.URI import System.FilePath -- }}} -labelNotify :: Environment -> IO () -labelNotify env = do - feedbackLabel <- builderGetObject ((mBuilder . mGUI) env) castToLabel "feedback" - labelSetMarkupTemporary feedbackLabel "Download started" 5000 - -aria, wget, axel :: URI -> FilePath -> String -> IO () -aria uri directory filename = spawn "aria2c" [show uri, "-d", directory, "-o", filename] -wget uri directory filename = spawn "wget" [show uri, "-O", directory filename] -axel uri directory filename = spawn "axel" [show uri, "-o", directory filename] + +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] diff --git a/Hbro/History.hs b/Hbro/History.hs --- a/Hbro/History.hs +++ b/Hbro/History.hs @@ -1,24 +1,27 @@ module Hbro.History ( Entry(..), + log, add, parseEntry, select ) where -- {{{ Imports ---import Hbro.Core ---import Hbro.Types +import Hbro.Core +import Hbro.Types import Hbro.Util import Control.Exception --import Control.Monad.Reader +import Data.Functor import Data.List -import Data.Time.Format -import Data.Time.LocalTime +import Data.Time import Network.URI +import Prelude hiding(log) + --import System.IO.Error import System.IO import System.Locale @@ -38,13 +41,22 @@ dateFormat = "%F %T" -- }}} --- | Add a new entry to history's database -add :: FilePath -- ^ Path to history file - -> Entry -- ^ History entry to add +-- | 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 () + +-- | Add a new entry to history file +add :: PortableFilePath -- ^ History file + -> Entry -- ^ History entry to add -> IO Bool -add historyFile newEntry = do - result <- try $ withFile historyFile AppendMode (`hPutStrLn` show newEntry) - either (\e -> errorHandler historyFile e >> return False) (const $ return True) result +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 -- | Try to parse a String into a history Entry. parseEntry :: String -> Maybe Entry @@ -60,22 +72,14 @@ parseEntry' _ = Nothing -- | Open a dmenu with all (sorted alphabetically) history entries, and return the user's selection, if any -select :: FilePath -- ^ Path to history file - -> [String] -- ^ dmenu's commandline options - -> IO (Maybe Entry) -- ^ Selected history entry, if any -select historyFile dmenuOptions = do - result <- try $ readFile historyFile +select :: PortableFilePath -- ^ Path to history file + -> [String] -- ^ dmenu's commandline options + -> IO (Maybe Entry) -- ^ Selected history entry, if any +select file dmenuOptions = do + file' <- resolve file + result <- try $ readFile file' - either (\e -> errorHandler historyFile e >> return Nothing) (return . return) result + either (\e -> errorHandler file' e >> return Nothing) (return . return) result >>= (return . ((return . unlines . reverse . sort . nub . lines) =<<)) >>= (maybe (return Nothing) (dmenu dmenuOptions)) >>= (return . (parseEntry =<<)) - - -reformat :: String -> String -reformat line = - let - _date:_time:uri:title = words line - in - unwords $ [uri] ++ title - diff --git a/Hbro/Misc.hs b/Hbro/Misc.hs --- a/Hbro/Misc.hs +++ b/Hbro/Misc.hs @@ -1,74 +1,44 @@ module Hbro.Misc where -- {{{ Imports ---import Hbro.Core ---import Hbro.Types +import Hbro.Core +import Hbro.Types import Hbro.Util +import Data.Functor import Data.Maybe -import Graphics.UI.Gtk.Display.Label +-- 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 -import System.IO +-- import System.IO -- }}} --- | Same as goBack function from Hbro.Core, --- but with feedback in case of failure. ---goForward :: WebView -> IO () ---goForward webView = do --- result <- webViewCanGoForward webView --- feedbackLabel <- builderGetObject builder castToLabel "feedback" --- --- case result of --- True -> webViewGoForward webView --- _ -> labelSetMarkupTemporary feedbackLabel "Unable to go forward !" 5000 >> return () --- --- where --- webView = mWebView $ mGUI browser --- builder = mBuilder $ mGUI browser --- ----- | Same as goBack function from Hbro.Core, ----- but with feedback in case of failure. ---goBack :: Browser -> IO () ---goBack browser = do --- result <- webViewCanGoBack webView --- feedbackLabel <- builderGetObject builder castToLabel "feedback" --- --- case result of --- True -> webViewGoBack webView --- _ -> labelSetMarkupTemporary feedbackLabel "Unable to go back !" 5000 >> return () --- --- where --- webView = mWebView $ mGUI browser --- builder = mBuilder $ mGUI browser - - -- | List preceding URIs in dmenu and let the user select which one to load. -goBackList :: WebView -> [String] -> IO (Maybe URI) -goBackList webView dmenuOptions = do - list <- webViewGetBackForwardList webView - n <- webBackForwardListGetBackLength list - backList <- webBackForwardListGetBackListWithLimit list n - dmenuList <- mapM itemToEntry backList +goBackList :: [String] -> K (Maybe URI) +goBackList dmenuOptions = do + list <- with (mWebView . mGUI) webViewGetBackForwardList + n <- io $ webBackForwardListGetBackLength list + backList <- io $ webBackForwardListGetBackListWithLimit list n + dmenuList <- io $ mapM itemToEntry backList - (>>= (parseURIReference . head . words)) `fmap` (dmenu dmenuOptions $ (unlines . catMaybes) dmenuList) + (>>= (parseURIReference . head . words)) <$> (io . dmenu dmenuOptions . unlines . catMaybes) dmenuList -- | List succeeding URIs in dmenu and let the user select which one to load. -goForwardList :: WebView -> [String] -> IO (Maybe URI) -goForwardList webView dmenuOptions = do - list <- webViewGetBackForwardList webView - n <- webBackForwardListGetForwardLength list - forwardList <- webBackForwardListGetForwardListWithLimit list n - dmenuList <- mapM itemToEntry forwardList +goForwardList :: [String] -> K (Maybe URI) +goForwardList dmenuOptions = do + list <- with (mWebView . mGUI) webViewGetBackForwardList + n <- io $ webBackForwardListGetForwardLength list + forwardList <- io $ webBackForwardListGetForwardListWithLimit list n + dmenuList <- io $ mapM itemToEntry forwardList - (>>= (parseURIReference . head . words)) `fmap` (dmenu dmenuOptions $ (unlines . catMaybes) dmenuList) + (>>= (parseURIReference . head . words)) `fmap` (io . dmenu dmenuOptions . unlines . catMaybes) dmenuList itemToEntry :: WebHistoryItem -> IO (Maybe String) @@ -78,12 +48,3 @@ case uri of Just u -> return $ Just (u ++ " | " ++ (maybe "Untitled" id title)) _ -> return Nothing - - --- | Toggle source display. --- Current implementation forces a refresh of current web page, which may be undesired. -toggleSourceMode :: WebView -> IO () -toggleSourceMode webView = do - currentMode <- webViewGetViewSourceMode webView - webViewSetViewSourceMode webView (not currentMode) - webViewReload webView diff --git a/Hbro/Session.hs b/Hbro/Session.hs --- a/Hbro/Session.hs +++ b/Hbro/Session.hs @@ -2,40 +2,40 @@ -- {{{ Imports --import Hbro.Types -import Hbro.Util +-- import Hbro.Util -import Data.Foldable -import qualified Data.Text as T -import qualified Data.Text.IO as T +-- 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 Graphics.UI.Gtk.General.General +-- import Graphics.UI.Gtk.WebKit.WebView hiding(webViewGetUri) -import Prelude hiding(mapM_) +-- import Prelude hiding(mapM_) -import System.Directory -import System.Environment -import System.Glib.Signals -import System.IO -import System.Posix.Process -import System.Process +-- 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 () +--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 () diff --git a/Hbro/StatusBar.hs b/Hbro/StatusBar.hs --- a/Hbro/StatusBar.hs +++ b/Hbro/StatusBar.hs @@ -1,9 +1,11 @@ module Hbro.StatusBar where -- {{{ Imports +import Hbro.Core --import Hbro.Keys +import Hbro.Gui import Hbro.Types ---import Hbro.Util +import Hbro.Util import Control.Monad hiding(forM_, mapM_) @@ -15,7 +17,7 @@ import Graphics.Rendering.Pango.Layout import Graphics.UI.Gtk.Display.Label -import Graphics.UI.Gtk.Gdk.EventM +--import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.Misc.Adjustment import Graphics.UI.Gtk.Scrolling.ScrolledWindow import Graphics.UI.Gtk.WebKit.WebView @@ -28,87 +30,70 @@ -- }}} --- | Write current scroll position in the given Label. -setupScrollWidget :: Label -> ScrolledWindow -> IO () -setupScrollWidget widget window = do - labelSetAttributes widget [ - AttrForeground {paStart = 0, paEnd = -1, paColor = Color 32767 32767 32767} - ] - - adjustment <- scrolledWindowGetVAdjustment window +-- notify :: Environment -> String -> Color -> IO () +-- notify env text color = do +-- widget <- builderGetObject ((mBuilder . mGUI) env) castToLabel "feedback" +-- labelSetAttributes widget [Attrforeground{ paStart = 0, paEnd = -1, paColor = color }] +-- labelSetMarkupTemporary widget text 5000 - _ <- 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%" - +-- | Write current scroll position in the given Label. +setupScrollWidget :: Label -> K () +setupScrollWidget widget = do + adjustment <- with (mScrollWindow . mGUI) $ scrolledWindowGetVAdjustment + io $ do + 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%" -- | /!\ Doesn't work for now. -- Write current zoom level in the given Label. -statusBarZoomLevel :: Label -> WebView -> IO () -statusBarZoomLevel widget webView = do - zoomLevel <- webViewGetZoomLevel webView - - labelSetMarkup widget $ "x" ++ escapeMarkup (show zoomLevel) ++ "" +setupZoomWidget :: Label -> K () +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 - -- | -withFeedback :: Label -> KeyEventCallback -> [Modifier] -> String -> IO Bool -withFeedback widget callback modifiers keys = do --- Trigger callback - result <- callback modifiers keys - --- Set color depending on result - let color = case result of - True -> Color 0 65535 0 - _ -> Color 65535 0 0 - - labelSetAttributes widget [ - AttrForeground {paStart = 0, paEnd = -1, paColor = color} - ] +printInLabel :: String -> (String, Bool) -> K (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}] --- Write keystrokes state to label - case (modifiers, isSuffixOf "" keys) of - (_ , True) -> labelSetText widget [] - ([], _) -> labelSetText widget keys - (_, _) -> labelSetText widget (show modifiers ++ keys) + case match of + True -> labelSetText widget [] + _ -> labelSetText widget keystrokes - return result - + return (keystrokes, match) -- | Write current load progress in the given Label. -statusBarLoadProgress :: Label -> WebView -> IO () -statusBarLoadProgress widget webView = do +setupProgressWidget :: Label -> K () +setupProgressWidget widget = with (mWebView . mGUI) $ \webView -> do -- Load started _ <- on webView loadStarted $ \_ -> do - labelSetAttributes widget [ - AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0} - ] + labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0}] labelSetText widget "0%" -- Progress changed _ <- on webView progressChanged $ \progress' -> do - labelSetAttributes widget [ - AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 65535 0} - ] + labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 65535 0}] labelSetText widget $ show progress' ++ "%" -- Load finished _ <- on webView loadFinished $ \_ -> do - labelSetAttributes widget [ - AttrForeground {paStart = 0, paEnd = -1, paColor = Color 0 65535 0} - ] + labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 0 65535 0}] labelSetText widget "100%" -- Error _ <- on webView loadError $ \_ _ _ -> do - labelSetAttributes widget [ - AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0} - ] + labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0}] labelSetText widget "ERROR" return False @@ -116,8 +101,8 @@ -- | Write current URI, or the destination of a hovered link, in the given Label. -setupURIWidget :: URIColors -> URIColors -> Label -> WebView -> IO () -setupURIWidget normalColors secureColors widget webView = do +setupURIWidget :: URIColors -> URIColors -> Label -> K () +setupURIWidget normalColors secureColors widget = with (mWebView . mGUI) $ \webView -> do -- URI changed _ <- on webView loadCommitted $ \_ -> (mapM_ (labelSetURI normalColors secureColors widget)) =<< ((>>= parseURIReference) `fmap` (webViewGetUri webView)) @@ -141,10 +126,9 @@ let i:j:k:l:_ = map length [ uriScheme uri, - maybe "" uriRegName (uriAuthority uri), + maybe [] uriRegName (uriAuthority uri), uriPath uri, - uriQuery uri - ] + uriQuery uri] labelSetAttributes widget $ [ AttrWeight{ paStart = 0, paEnd = -1, paWeight = WeightBold }, @@ -152,8 +136,7 @@ AttrForeground{ paStart = i+2, paEnd = i+2+j, paColor = mHost colors }, 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 } - ] + AttrForeground{ paStart = i+2+j+k+l, paEnd = -1, paColor = mFragment colors }] labelSetText widget (show uri) @@ -174,7 +157,7 @@ mHost = Color 50000 50000 50000, mPort = Color 65535 0 0, mUser = Color 0 65535 0, - mPath = Color 0 65535 65535, + mPath = Color 20000 20000 20000, mQuery = Color 20000 20000 20000, mFragment = Color 10000 10000 65535 } diff --git a/Hbro/WebSettings.hs b/Hbro/WebSettings.hs new file mode 100644 --- /dev/null +++ b/Hbro/WebSettings.hs @@ -0,0 +1,32 @@ +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/README.rst b/README.rst --- a/README.rst +++ b/README.rst @@ -2,9 +2,10 @@ hbro-contrib ============ -This package gathers third-party extensions to *hbro_*. +This package gathers third-party extensions for * hbro_ *. Informations about versions, dependencies, source repositories and contacts can be found in hackage_. .. _hbro: http://hackage.haskell.org/package/hbro +.. _hackage: http://hackage.haskell.org/package/hbro-contrib diff --git a/examples/hbro.hs b/examples/hbro.hs --- a/examples/hbro.hs +++ b/examples/hbro.hs @@ -3,8 +3,8 @@ -- {{{ Imports import qualified Hbro.Bookmarks as Bookmarks -import qualified Hbro.BookmarksQueue as Queue import Hbro.Clipboard +import Hbro.Config import Hbro.Core import qualified Hbro.Download as Download import Hbro.Gui @@ -12,15 +12,18 @@ 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.StatusBar import Hbro.Types import Hbro.Util +import Hbro.WebSettings import Control.Monad hiding(forM_, mapM_) import Data.Foldable +import Data.Functor import Data.Time import Graphics.UI.Gtk.Abstract.Widget @@ -33,9 +36,7 @@ import Graphics.UI.Gtk.WebKit.Download import Graphics.UI.Gtk.WebKit.NetworkRequest import Graphics.UI.Gtk.WebKit.WebNavigationAction -import Graphics.UI.Gtk.WebKit.WebPolicyDecision import Graphics.UI.Gtk.WebKit.WebSettings -import Graphics.UI.Gtk.WebKit.WebView hiding(webViewGetUri, webViewLoadUri) import Graphics.UI.Gtk.Windows.Window import Network.URI @@ -53,137 +54,90 @@ -- }}} -- Main function, expected to call launchHbro. --- You can add custom tasks before & after calling it. main :: IO () main = launchHbro myConfig --- A structure containing your configuration settings, overriding --- fields in the default config. Any you don't override will --- use the defaults defined in Hbro.Types.Parameters. -myConfig :: CommonDirectories -> Config -myConfig directories = (defaultConfig directories) { - mSocketDir = mySocketDirectory directories, - mUIFile = myUIFile directories, - mKeyEventHandler = myKeyEventHandler, - mKeyEventCallback = myKeyEventCallback, +-- {{{ Configuration structures +-- 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, - mSetup = mySetup, - mDownloadHook = myDownloadHook +-- mCommandsList = myCommandsList, + mHooks = myHooks } --- Various constant parameters -myHomePage = "https://duckduckgo.com" - -mySocketDirectory, myUIFile, myHistoryFile, myBookmarksFile :: CommonDirectories -> FilePath -mySocketDirectory = mTemporary -myUIFile directories = (mConfiguration directories) "ui.xml" -myHistoryFile directories = (mData directories) "history" -myBookmarksFile directories = (mData directories) "bookmarks" +myHooks = defaultHooks { +-- mBackForward = myBackForward, + mDownload = myDownloadHook, +-- mFormResubmitted = myFormResubmitted, +-- mFormSubmitted = myFormSubmitted, + mKeyPressed = manageSequentialKeys (defaultKeyHandler myKeys) >=> void . (printInLabel "keys"), +-- mLinkClicked = myLinkClicked, + mLoadFinished = myLoadFinished, +-- mMIMEDisposition = myMIMEDisposition, +-- mNewWindow = myNewWindowHook, +-- mOtherNavigation = myOtherNavigation, +-- mReload = myReload, + mStartUp = myStartUp +-- mTitleChanged = myTitleChanged +} +-- }}} --- How to download files -myDownloadHook :: Environment -> URI -> String -> Int -> IO () -myDownloadHook env uri filename _size = do - Download.labelNotify env - home <- getHomeDirectory - Download.aria uri home filename +-- {{{ Constant parameters +myHomePage = "https://duckduckgo.com" --- How to handle keystrokes -myKeyEventHandler :: KeyEventCallback -> ConnectId WebView -> WebView -> EventM EKey Bool -myKeyEventHandler = advancedKeyEventHandler +myUIFile, myHistoryFile, myBookmarksFile, myDownloadDirectory :: PortableFilePath +myUIFile directories = (mConfiguration directories) "ui.xml" +myHistoryFile directories = (mData directories) "history" +myBookmarksFile directories = (mData directories) "bookmarks" +myDownloadDirectory = mHome +-- }}} -myKeyEventCallback :: Environment -> KeyEventCallback -myKeyEventCallback environment@Environment{ mGUI = gui } modifiers keys = do - keysLabel <- builderGetObject (mBuilder gui) castToLabel "keys" - withFeedback keysLabel (simpleKeyEventCallback $ keysListToMap (myKeys environment)) modifiers keys +-- {{{ Hooks +myDownloadHook :: URI -> String -> Int -> K () +myDownloadHook uri filename _size = io $ Download.aria myDownloadDirectory uri filename +myLoadFinished :: K () +myLoadFinished = History.log myHistoryFile +-- }}} -- {{{ Keys -- Note that this example is suited for an azerty keyboard. -myKeys :: Environment -> KeysList -myKeys environment@Environment{ mGUI = gui, mConfig = config, mContext = context } = let - window = mWindow gui - webView = mWebView gui - scrolledWindow = mScrollWindow gui - statusBox = mStatusBar gui - promptBar = mPromptBar gui - promptEntry = mEntry promptBar - bookmarksFile = myBookmarksFile (mCommonDirectories config) - historyFile = myHistoryFile (mCommonDirectories config) - socketDir = mSocketDir config - in - [ --- ((modifiers, key), callback) +myKeys :: KeysList +myKeys = defaultKeyBindings ++ [ -- Browse - (([Control], ""), webViewGoBack webView), - (([Control], ""), webViewGoForward webView), - (([Alt], ""), (goBackList webView ["-l", "10"]) >>= mapM_ (webViewLoadUri webView)), - (([Alt], ""), (goForwardList webView ["-l", "10"]) >>= mapM_ (webViewLoadUri webView)), - (([Control], "s"), webViewStopLoading webView), - (([], ""), webViewReload webView), - (([Control], ""), webViewReloadBypassCache webView), - (([Control], "^"), goLeft scrolledWindow), - (([Control], "$"), goRight scrolledWindow), - (([Control], ""), goTop scrolledWindow), - (([Control], ""), goBottom scrolledWindow), - (([Alt], ""), goHome webView config), - (([Control], "g"), prompt "Google search" [] (\words -> forM_ (parseURIReference ("https://www.google.com/search?q=" ++ words)) (webViewLoadUri webView)) gui), - --- Display - (([Control, Shift], "+"), webViewZoomIn webView), - (([Control], "-"), webViewZoomOut webView), - (([], ""), windowFullscreen window), - (([], ""), windowUnfullscreen window), - (([Control], "b"), toggleVisibility statusBox), - (([Control], "u"), toggleSourceMode webView), - --- Prompt - (([Control], "o"), prompt "Open URL " [] ((mapM_ (webViewLoadUri webView)) . parseURIReference) gui), - (([Control, Shift], "O"), webViewGetUri webView >>= mapM_ (\uri -> prompt "Open URL " (show uri) ((mapM_ (webViewLoadUri webView)) . parseURIReference) gui)), - --- Search - (([Shift], "/"), promptIncremental "Search " [] (\word -> webViewSearchText webView word False True True >> return ()) gui), - (([Control], "f"), promptIncremental "Search " [] (\word -> webViewSearchText webView word False True True >> return ()) gui), - (([Shift], "?"), promptIncremental "Search " [] (\word -> webViewSearchText webView word False False True >> return ()) gui), - (([Control], "n"), entryGetText promptEntry >>= \word -> webViewSearchText webView word False True True >> return ()), - (([Control, Shift], "N"), entryGetText promptEntry >>= \word -> webViewSearchText webView word False False True >> return ()), - + ("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 - (([Control], "y"), webViewGetUri webView >>= mapM_ (toClipboard . show)), - (([Control, Shift], "Y"), webViewGetTitle webView >>= mapM_ toClipboard), - (([Control], "p"), withClipboard $ maybe (return ()) ((mapM_ (webViewLoadUri webView)) . parseURIReference)), - (([Control, Shift], "P"), withClipboard $ maybe (return ()) (\uri -> spawn "hbro" ["-u", uri])), - --- Misc - (([], ""), widgetHide $ mBox promptBar), - (([Control], "i"), showWebInspector webView), - (([Alt], "p"), printPage webView), - (([Control], "t"), spawn "hbro" []), - (([Control], "w"), mainQuit), - + ("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]), -- Bookmarks - (([Control], "d"), webViewGetUri webView >>= mapM_ (\uri -> - prompt "Bookmark with tags:" "" (\tags -> void $ - Bookmarks.add bookmarksFile (Bookmarks.Entry uri (words tags))) - gui)), - (([Control, Shift], "D"), prompt "Bookmark all instances with tag:" "" (\tags -> - ((map parseURI) `fmap` (sendCommandToAll context socketDir "GET_URI")) - >>= mapM (mapM_ $ \uri -> Bookmarks.add bookmarksFile $ Bookmarks.Entry uri (words tags)) - >> (webViewGetUri webView) >>= mapM_ (\uri -> Bookmarks.add bookmarksFile $ Bookmarks.Entry uri (words tags))) - gui), - (([Alt], "d"), Bookmarks.deleteWithTag bookmarksFile ["-l", "10"]), - (([Control], "l"), Bookmarks.select bookmarksFile ["-l", "10"] >>= mapM_ ((mapM_ (webViewLoadUri webView)) . parseURIReference)), - (([Control, Shift], "L"), Bookmarks.selectTag bookmarksFile ["-l", "10"] >>= mapM_ (\uris -> mapM (\uri -> spawn "hbro" ["-u", (show uri)]) uris >> return ())), --- (([Control], "q"), webViewGetUri webView >>= maybe (return ()) (Queue.append), --- (([Alt], "q"), \b -> do + ("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)) + ), + ("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)), +-- ("C-q"), webViewGetUri webView >>= maybe (return ()) (Queue.append), +-- ("M-q"), \b -> do -- uri <- Queue.popFront -- loadURI uri b), -- History - (([Control], "h"), History.select historyFile ["-l", "10"] >>= mapM_ ((webViewLoadUri webView) . History.mURI)) + ("C-h", io (History.select myHistoryFile ["-l", "10"]) >>= mapM_ loadURI . (return . (History.mURI) =<<)) -- Session - --(([Alt], "l"), loadFromSession ["-l", "10"]) + --("M-l"), loadFromSession ["-l", "10"]) ] -- }}} @@ -195,7 +149,7 @@ --webSettingsCursiveFontFamily := "serif", --webSettingsDefaultFontFamily := "sans-serif", --webSettingsFantasyFontFamily := , - --webSettingsMonospaceFontFamily := "monospace", + webSettingsMonospaceFontFamily := "consolas", --webSettingsSansFontFamily := "sans-serif", --webSettingsSerifFontFamily := "serif", --webSettingsDefaultFontSize := , @@ -206,12 +160,12 @@ --webSettingsAutoShrinkImages := True, --webSettingsDefaultEncoding := "iso-8859-1", --webSettingsEditingBehavior := EditingBehaviorWindows, - --webSettingsEnableCaretBrowsing := False, + --webSettingsEnableCaretBrowsing := False, webSettingsEnableDeveloperExtras := True, --webSettingsEnableHtml5Database := True, --webSettingsEnableHtml5LocalStorage := True, --webSettingsEnableOfflineWebApplicationCache := True, - webSettingsEnablePlugins := True, + webSettingsEnablePlugins := False, webSettingsEnablePrivateBrowsing := False, -- Experimental webSettingsEnableScripts := False, --webSettingsEnableSpellChecking := False, @@ -228,94 +182,30 @@ --webSettingsResizableTextAreas := True, webSettingsSpellCheckingLang := Just "en_US", --webSettingsTabKeyCyclesThroughElements := True, - webSettingsUserAgent := "Mozilla/5.0 (X11; Linux x86_64; rv:2.0.1) Gecko/20100101 Firefox/4.0.1" + webSettingsUserAgent := firefoxUserAgent --webSettingsUserStylesheetUri := Nothing, --webSettingsZoomStep := 0.1 ] -- }}} -- {{{ Setup -mySetup :: Environment -> IO () -mySetup environment@Environment{ mGUI = gui, mConfig = config } = - let - builder = mBuilder gui - webView = mWebView gui - scrolledWindow = mScrollWindow gui - window = mWindow gui - directories = mCommonDirectories config - historyFile = myHistoryFile directories - getLabel = builderGetObject builder castToLabel - in do +myStartUp :: K () +myStartUp = do -- Scroll position in status bar - scrollLabel <- getLabel "scroll" - setupScrollWidget scrollLabel scrolledWindow + setupScrollWidget =<< getObject castToLabel "scroll" -- Zoom level in status bar - zoomLabel <- getLabel "zoom" - statusBarZoomLevel zoomLabel webView + setupZoomWidget =<< getObject castToLabel "zoom" -- Load progress in status bar - progressLabel <- getLabel "progress" - statusBarLoadProgress progressLabel webView + setupProgressWidget =<< getObject castToLabel "progress" -- Current URI in status bar - uriLabel <- getLabel "uri" - setupURIWidget defaultURIColors defaultSecureURIColors uriLabel webView + setupURIWidget defaultURIColors defaultSecureURIColors =<< getObject castToLabel "uri" -- Session manager --setupSession browser - - -- - _ <- on webView titleChanged $ \_ title -> - set window [ windowTitle := ("hbro | " ++ title)] - - -- Per MIME actions - _ <- on webView mimeTypePolicyDecisionRequested $ \_ request mimetype policyDecision -> do - show <- webViewCanShowMimeType webView mimetype - - case (show, mimetype) of - (True, _) -> webPolicyDecisionUse policyDecision >> return True - _ -> webPolicyDecisionDownload policyDecision >> return True - - -- History handler - _ <- on webView loadFinished $ \_ -> do - uri <- webViewGetUri webView - title <- webViewGetTitle webView - timeZone <- getCurrentTimeZone - now <- (utcToLocalTime timeZone) `fmap` getCurrentTime - case (uri, title) of - (Just u, Just t) -> History.add historyFile (History.Entry now u t) >> return () - _ -> return () - - -- On navigating to a new URI - -- Return True to forbid navigation, False to allow - _ <- on webView navigationPolicyDecisionRequested $ \_ request action policyDecision -> do - getUri <- networkRequestGetUri request - reason <- webNavigationActionGetReason action - mouseButton <- webNavigationActionGetButton action - - case getUri of - Just ('m':'a':'i':'l':'t':'o':':':address) -> do - putStrLn $ "Mailing to: " ++ address - return True - Just uri -> - case mouseButton of - 1 -> return False -- Left button - 2 -> spawn "hbro" ["-u", uri] >> putStrLn uri >> return True -- Middle button - 3 -> return False -- Right button - _ -> return False -- No mouse button pressed - _ -> return False - - -- On requesting new window - _ <- on webView newWindowPolicyDecisionRequested $ \_ request action policyDecision -> do - getUri <- networkRequestGetUri request - case getUri of - Just uri -> (spawn "hbro" ["-u", uri]) >> putStrLn uri - _ -> putStrLn "ERROR: wrong URI given, unable to open window." - - return True - -- Favicon --_ <- on webView iconLoaded $ \uri -> do something diff --git a/examples/ui.xml b/examples/ui.xml --- a/examples/ui.xml +++ b/examples/ui.xml @@ -100,6 +100,26 @@ + + + + + False + 5 + + + + True + 0 + + + + + + False + False + + diff --git a/hbro-contrib.cabal b/hbro-contrib.cabal --- a/hbro-contrib.cabal +++ b/hbro-contrib.cabal @@ -1,8 +1,8 @@ Name: hbro-contrib -Version: 0.8.0.0 +Version: 0.9.0.0 Synopsis: Third-party extensions to hbro. -- Description: -Homepage: http://projects.haskell.org/hbro-contrib/ +Homepage: https://github.com/k0ral/hbro-contrib/ Category: Browser,Web License: OtherLicense @@ -27,22 +27,24 @@ filepath, glib, gtk, - hbro, + hbro >= 0.9.0.0, network, old-locale, pango, process, + -- random-extras, + -- random-fu, text, time, unix, webkit Exposed-modules: Hbro.Bookmarks, - Hbro.BookmarksQueue, Hbro.Clipboard, Hbro.Download, Hbro.History, Hbro.Misc, Hbro.Session, - Hbro.StatusBar + Hbro.StatusBar, + Hbro.WebSettings Ghc-options: -Wall