diff --git a/Hbro/Bookmarks.hs b/Hbro/Bookmarks.hs
new file mode 100644
--- /dev/null
+++ b/Hbro/Bookmarks.hs
@@ -0,0 +1,112 @@
+module Hbro.Bookmarks (
+ Entry(..),
+ add,
+ select,
+ selectTag,
+ deleteWithTag
+) where
+
+-- {{{ Imports
+--import Hbro.Core
+--import Hbro.Gui
+--import Hbro.Types
+import Hbro.Util
+
+import Control.Exception
+import Control.Monad hiding(forM_, mapM_)
+
+--import qualified Data.ByteString.Char8 as B
+import Data.Foldable hiding(find, foldr)
+import Data.List
+import Data.Maybe
+
+import Network.URI
+
+import Prelude hiding(catch, mapM_)
+
+import System.IO
+-- }}}
+
+-- {{{ Type definitions
+data Entry = Entry {
+ mURI :: URI,
+ mTags :: [String]
+}
+
+instance Show Entry where
+ show (Entry uri tags) = unwords $ (show uri):tags
+-- }}}
+
+-- | Try to parse a String into a bookmark Entry.
+parseEntry :: String -> Maybe Entry
+parseEntry [] = Nothing
+parseEntry line = return (words line)
+ >>= (\(h:t) -> parseURI h
+ >>= (\uri -> listToMaybe t
+ >> (return $ Entry uri t)))
+
+-- | Check if the given bookmark Entry is tagged with the given tag.
+hasTag :: String -> Entry -> Bool
+hasTag tag = isJust . (find $ (==) tag) . mTags
+
+-- | Add 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
+
+-- | 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
+
+ either (\e -> errorHandler bookmarksFile 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) =<<))
+
+
+reformat :: String -> String
+reformat line = unwords $ tags' ++ [uri]
+ where
+ uri:tags = words line
+ tags' = sort $ map (\tag -> '[':(tag ++ "]")) tags
+
+-- | Open a dmenu with all (sorted alphabetically) bookmarks tags, and return the user's selection, if any.
+selectTag :: FilePath -- ^ 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
+
+ let entries = (return . catMaybes . (map parseEntry) . lines) =<< file
+ let tags = (return . unlines . sort . nub . words . unwords . (foldr (union . mTags) [])) =<< entries
+
+ -- Let user select a tag
+ tag <- (maybe (return Nothing) (dmenu dmenuOptions) tags)
+ return $ (return . (map mURI) . (\t -> filter (hasTag t) (maybe [] id entries))) =<< tag
+
+
+-- | Remove all bookmarks entries matching the given tag.
+deleteWithTag :: FilePath -- ^ 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
+
+ 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
+ return ())
diff --git a/Hbro/BookmarksQueue.hs b/Hbro/BookmarksQueue.hs
new file mode 100644
--- /dev/null
+++ b/Hbro/BookmarksQueue.hs
@@ -0,0 +1,81 @@
+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
new file mode 100644
--- /dev/null
+++ b/Hbro/Clipboard.hs
@@ -0,0 +1,17 @@
+module Hbro.Clipboard where
+
+-- {{{ Imports
+--import Hbro.Core
+--import Hbro.Types
+--import Hbro.Util
+
+import Graphics.UI.Gtk.General.Clipboard
+-- }}}
+
+
+-- | Copy current URI in clipboard.
+toClipboard :: String -> IO ()
+toClipboard text = clipboardGet selectionPrimary >>= (`clipboardSetText` text)
+
+withClipboard :: (Maybe String -> IO ()) -> IO ()
+withClipboard callback = clipboardGet selectionPrimary >>= (`clipboardRequestText` callback)
diff --git a/Hbro/Download.hs b/Hbro/Download.hs
new file mode 100644
--- /dev/null
+++ b/Hbro/Download.hs
@@ -0,0 +1,23 @@
+module Hbro.Download where
+
+-- {{{ Imports
+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]
diff --git a/Hbro/History.hs b/Hbro/History.hs
new file mode 100644
--- /dev/null
+++ b/Hbro/History.hs
@@ -0,0 +1,81 @@
+module Hbro.History (
+ Entry(..),
+ add,
+ parseEntry,
+ select
+) where
+
+-- {{{ Imports
+--import Hbro.Core
+--import Hbro.Types
+import Hbro.Util
+
+import Control.Exception
+--import Control.Monad.Reader
+
+import Data.List
+import Data.Time.Format
+import Data.Time.LocalTime
+
+import Network.URI
+
+--import System.IO.Error
+import System.IO
+import System.Locale
+-- }}}
+
+-- {{{ Type definitions
+data Entry = Entry {
+ mTime :: LocalTime,
+ mURI :: URI,
+ mTitle :: String
+}
+
+instance Show Entry where
+ show (Entry time uri title) = unwords [(formatTime defaultTimeLocale dateFormat time), show uri, title]
+
+dateFormat :: String
+dateFormat = "%F %T"
+-- }}}
+
+-- | Add a new entry to history's database
+add :: FilePath -- ^ Path to 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
+
+-- | Try to parse a String into a history Entry.
+parseEntry :: String -> Maybe Entry
+parseEntry [] = Nothing
+parseEntry line = (parseEntry' . words) line
+
+parseEntry' :: [String] -> Maybe Entry
+parseEntry' (d:t:u:t') = do
+ time <- parseTime defaultTimeLocale dateFormat (unwords [d, t])
+ uri <- parseURI u
+
+ return $ Entry time uri (unwords t')
+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
+
+ either (\e -> errorHandler historyFile 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
new file mode 100644
--- /dev/null
+++ b/Hbro/Misc.hs
@@ -0,0 +1,89 @@
+module Hbro.Misc where
+
+-- {{{ Imports
+--import Hbro.Core
+--import Hbro.Types
+import Hbro.Util
+
+import Data.Maybe
+
+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
+-- }}}
+
+
+-- | 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
+
+ (>>= (parseURIReference . head . words)) `fmap` (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
+
+ (>>= (parseURIReference . head . words)) `fmap` (dmenu dmenuOptions $ (unlines . catMaybes) dmenuList)
+
+
+itemToEntry :: WebHistoryItem -> IO (Maybe String)
+itemToEntry item = do
+ title <- webHistoryItemGetTitle item
+ uri <- webHistoryItemGetUri item
+ 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
new file mode 100644
--- /dev/null
+++ b/Hbro/Session.hs
@@ -0,0 +1,60 @@
+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
new file mode 100644
--- /dev/null
+++ b/Hbro/StatusBar.hs
@@ -0,0 +1,186 @@
+module Hbro.StatusBar where
+
+-- {{{ Imports
+--import Hbro.Keys
+import Hbro.Types
+--import Hbro.Util
+
+import Control.Monad hiding(forM_, mapM_)
+
+import Data.Foldable
+import Data.List
+import Data.Maybe
+
+import Graphics.Rendering.Pango.Enums
+import Graphics.Rendering.Pango.Layout
+
+import Graphics.UI.Gtk.Display.Label
+import Graphics.UI.Gtk.Gdk.EventM
+import Graphics.UI.Gtk.Misc.Adjustment
+import Graphics.UI.Gtk.Scrolling.ScrolledWindow
+import Graphics.UI.Gtk.WebKit.WebView
+
+import Network.URI
+
+import Prelude hiding(mapM_)
+
+import System.Glib.Signals
+-- }}}
+
+
+-- | 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
+
+ _ <- 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) ++ ""
+
+
+-- |
+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}
+ ]
+
+-- Write keystrokes state to label
+ case (modifiers, isSuffixOf "" keys) of
+ (_ , True) -> labelSetText widget []
+ ([], _) -> labelSetText widget keys
+ (_, _) -> labelSetText widget (show modifiers ++ keys)
+
+ return result
+
+
+-- | Write current load progress in the given Label.
+statusBarLoadProgress :: Label -> WebView -> IO ()
+statusBarLoadProgress widget webView = do
+-- Load started
+ _ <- on webView loadStarted $ \_ -> do
+ labelSetAttributes widget [
+ AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 0 0}
+ ]
+ labelSetText widget "0%"
+-- Progress changed
+ _ <- on webView progressChanged $ \progress' -> do
+ 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}
+ ]
+ labelSetText widget "100%"
+-- Error
+ _ <- on webView 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 :: URIColors -> URIColors -> Label -> WebView -> IO ()
+setupURIWidget normalColors secureColors widget webView = do
+-- URI changed
+ _ <- on webView loadCommitted $ \_ ->
+ (mapM_ (labelSetURI normalColors secureColors widget)) =<< ((>>= parseURIReference) `fmap` (webViewGetUri webView))
+
+-- Link (un)hovered
+ _ <- on webView hoveringOverLink $ \_title hoveredURI -> do
+ uri <- webViewGetUri webView
+
+ forM_ (hoveredURI >>= parseURIReference) $ labelSetURI normalColors secureColors widget
+ unless (isJust hoveredURI) $ forM_ (uri >>= parseURIReference) (labelSetURI normalColors secureColors widget)
+
+ 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 },
+ 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 }
+ ]
+
+ labelSetText widget (show uri)
+
+
+data URIColors = URIColors {
+ mScheme :: Color,
+ mHost :: Color,
+ mPort :: Color,
+ mUser :: Color,
+ mPath :: Color,
+ mQuery :: Color,
+ mFragment :: Color
+}
+
+defaultURIColors :: URIColors
+defaultURIColors = URIColors {
+ mScheme = Color 20000 20000 20000,
+ mHost = Color 50000 50000 50000,
+ mPort = Color 65535 0 0,
+ mUser = Color 0 65535 0,
+ mPath = Color 0 65535 65535,
+ mQuery = Color 20000 20000 20000,
+ mFragment = Color 10000 10000 65535
+}
+
+
+defaultSecureURIColors :: URIColors
+defaultSecureURIColors = defaultURIColors {
+ mHost = Color 50000 50000 0
+}
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,13 @@
+DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE
+Version 2, December 2004
+
+Copyright (C) 2011 koral
+
+Everyone is permitted to copy and distribute verbatim or modified
+copies of this license document, and changing it is allowed as long
+as the name is changed.
+
+DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE
+TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+0. You just DO WHAT THE FUCK YOU WANT TO.
diff --git a/README.rst b/README.rst
new file mode 100644
--- /dev/null
+++ b/README.rst
@@ -0,0 +1,10 @@
+============
+hbro-contrib
+============
+
+This package gathers third-party extensions to *hbro_*.
+
+Informations about versions, dependencies, source repositories and contacts can be found in hackage_.
+
+
+.. _hbro: http://hackage.haskell.org/package/hbro
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/examples/hbro.hs b/examples/hbro.hs
new file mode 100644
--- /dev/null
+++ b/examples/hbro.hs
@@ -0,0 +1,323 @@
+{-# LANGUAGE DoRec #-}
+module Main where
+
+-- {{{ Imports
+import qualified Hbro.Bookmarks as Bookmarks
+import qualified Hbro.BookmarksQueue as Queue
+import Hbro.Clipboard
+import Hbro.Core
+import qualified Hbro.Download as Download
+import Hbro.Gui
+import Hbro.Hbro
+import qualified Hbro.History as History
+import Hbro.Keys
+import Hbro.Misc
+import Hbro.Session
+import Hbro.Socket
+import Hbro.StatusBar
+import Hbro.Types
+import Hbro.Util
+
+import Control.Monad hiding(forM_, mapM_)
+
+import Data.Foldable
+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.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
+
+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
+-- }}}
+
+-- 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,
+ mHomePage = myHomePage,
+ mWebSettings = myWebSettings,
+ mSetup = mySetup,
+ mDownloadHook = myDownloadHook
+}
+
+-- 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"
+
+-- 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
+
+-- How to handle keystrokes
+myKeyEventHandler :: KeyEventCallback -> ConnectId WebView -> WebView -> EventM EKey Bool
+myKeyEventHandler = advancedKeyEventHandler
+
+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
+
+
+-- {{{ 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)
+-- 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 ()),
+
+-- 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),
+
+-- 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
+-- uri <- Queue.popFront
+-- loadURI uri b),
+
+-- History
+ (([Control], "h"), History.select historyFile ["-l", "10"] >>= mapM_ ((webViewLoadUri webView) . History.mURI))
+
+-- Session
+ --(([Alt], "l"), loadFromSession ["-l", "10"])
+ ]
+-- }}}
+
+-- {{{ Web settings
+-- Commented out lines correspond to default values.
+myWebSettings :: [AttrOp WebSettings]
+myWebSettings = [
+-- SETTING VALUE
+ --webSettingsCursiveFontFamily := "serif",
+ --webSettingsDefaultFontFamily := "sans-serif",
+ --webSettingsFantasyFontFamily := ,
+ --webSettingsMonospaceFontFamily := "monospace",
+ --webSettingsSansFontFamily := "sans-serif",
+ --webSettingsSerifFontFamily := "serif",
+ --webSettingsDefaultFontSize := ,
+ --webSettingsDefaultMonospaceFontSize := 10,
+ --webSettingsMinimumFontSize := 5,
+ --webSettingsMinimumLogicalFontSize := 5,
+ --webSettingsAutoLoadImages := True,
+ --webSettingsAutoShrinkImages := True,
+ --webSettingsDefaultEncoding := "iso-8859-1",
+ --webSettingsEditingBehavior := EditingBehaviorWindows,
+ --webSettingsEnableCaretBrowsing := False,
+ webSettingsEnableDeveloperExtras := True,
+ --webSettingsEnableHtml5Database := True,
+ --webSettingsEnableHtml5LocalStorage := True,
+ --webSettingsEnableOfflineWebApplicationCache := True,
+ webSettingsEnablePlugins := True,
+ webSettingsEnablePrivateBrowsing := False, -- Experimental
+ webSettingsEnableScripts := False,
+ --webSettingsEnableSpellChecking := False,
+ webSettingsEnableUniversalAccessFromFileUris := True,
+ webSettingsEnableXssAuditor := True,
+ --webSettingsEnableSiteSpecificQuirks := False,
+ --webSettingsEnableDomPaste := False,
+ --webSettingsEnableDefaultContextMenu := True,
+ webSettingsEnablePageCache := True,
+ --webSettingsEnableSpatialNavigation := False,
+ --webSettingsEnforce96Dpi := ,
+ webSettingsJSCanOpenWindowAuto := True,
+ --webSettingsPrintBackgrounds := True,
+ --webSettingsResizableTextAreas := True,
+ webSettingsSpellCheckingLang := Just "en_US",
+ --webSettingsTabKeyCyclesThroughElements := True,
+ webSettingsUserAgent := "Mozilla/5.0 (X11; Linux x86_64; rv:2.0.1) Gecko/20100101 Firefox/4.0.1"
+ --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
+ -- Scroll position in status bar
+ scrollLabel <- getLabel "scroll"
+ setupScrollWidget scrollLabel scrolledWindow
+
+ -- Zoom level in status bar
+ zoomLabel <- getLabel "zoom"
+ statusBarZoomLevel zoomLabel webView
+
+ -- Load progress in status bar
+ progressLabel <- getLabel "progress"
+ statusBarLoadProgress progressLabel webView
+
+ -- Current URI in status bar
+ uriLabel <- getLabel "uri"
+ setupURIWidget defaultURIColors defaultSecureURIColors uriLabel webView
+
+ -- 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
+
+ return ()
+-- }}}
diff --git a/examples/ui.xml b/examples/ui.xml
new file mode 100644
--- /dev/null
+++ b/examples/ui.xml
@@ -0,0 +1,105 @@
+
+
+
diff --git a/hbro-contrib.cabal b/hbro-contrib.cabal
new file mode 100644
--- /dev/null
+++ b/hbro-contrib.cabal
@@ -0,0 +1,48 @@
+Name: hbro-contrib
+Version: 0.8.0.0
+Synopsis: Third-party extensions to hbro.
+-- Description:
+Homepage: http://projects.haskell.org/hbro-contrib/
+Category: Browser,Web
+
+License: OtherLicense
+License-file: LICENSE
+-- Copyright:
+Author: koral
+Maintainer: koral at mailoo dot org
+
+Cabal-version: >=1.8
+Build-type: Simple
+Extra-source-files: README.rst examples/hbro.hs
+Data-files: examples/ui.xml
+
+Source-repository head
+ Type: git
+ Location: git@github.com:k0ral/hbro-contrib.git
+
+Library
+ Build-depends:
+ base == 4.*,
+ directory,
+ filepath,
+ glib,
+ gtk,
+ hbro,
+ network,
+ old-locale,
+ pango,
+ process,
+ text,
+ time,
+ unix,
+ webkit
+ Exposed-modules:
+ Hbro.Bookmarks,
+ Hbro.BookmarksQueue,
+ Hbro.Clipboard,
+ Hbro.Download,
+ Hbro.History,
+ Hbro.Misc,
+ Hbro.Session,
+ Hbro.StatusBar
+ Ghc-options: -Wall